perm filename TOTAL[S,AIL]19 blob
sn#081258 filedate 1974-01-11 generic text, type T, neo UTF8
COMMENT ⊗ VALID 00049 PAGES VERSION 17-1(12)
RECORD PAGE DESCRIPTION
00001 00001
00006 00002 HISTORY
00012 00003 DATA for Total (Low-level Code Production) Routines
00015 00004 Description of Total Routines
00025 00005 CONV, PRE, POST -- Type-Conversion routines
00029 00006
00033 00007
00038 00008
00039 00009 PUT
00042 00010 ACCESS,GETSDR,GETDR,DISBLK,ZOTDIS--last four only for dis
00050 00011 GET
00054 00012
00057 00013
00060 00014
00064 00015 STACK -- Issue Instrs. to Stack Anything on Approp. Stack
00068 00016 MARK, MARKINT, MARKME -- Mark Semblk with Correct Temp Semantics
00071 00017 INCOR -- Issue Code to Clear this Entity from ACs
00072 00018 REMOPs, CLEARs -- Remove Temps, ACs, from Use
00078 00019 DSCR CLEAR,CLEARL,CLEARA
00080 00020 STROP -- Bit-Driven String Operation Code Generator
00085 00021 GETTEM, etc. -- Temp Semblk Allocators
00088 00022 GETAC, GETAN0 -- AC Allocators
00094 00023 AC Store routines -- BOLSTO, FORSTO, STORIX, GOSTO, STORZ
00099 00024 STORA -- main AC-storing subr. -- called by above
00104 00025 EMITER -- Descriptions of Routine and Control Bits
00107 00026 EMITER Routine
00111 00027
00116 00028 SUBI TEMP,1 FIX IT
00121 00029
00124 00030 Qstack Routines -- BPUSH, etc.
00128 00031
00131 00032
00134 00033 PWR2
00135 00034 GBOUT Description, Loader Block Format Description
00138 00035 Control Variables for Loader Block Output
00141 00036 Loader Output Blocks-- Entry, Program Name, Initial Stuff
00144 00037 Code, Boolean Code, Fixups, Links
00148 00038 Space Allocation Block
00152 00039 Request Blocks -- RELfile, Libraries
00154 00040 Ending Code, Symbols -- END Block
00158 00041 RELINI -- Loader Block Initialization
00159 00042 GBOUT Routine
00161 00043 CODOUT Routine -- Output Code or Data
00165 00044
00166 00045 FBOUT, etc. -- Output Fixups
00169 00046 SCOUT, etc. -- Output Symbols
00173 00047 LNKOUT -- Output Linkage Block
00175 00048 PRGOUT, FILSCN -- Output Request Blocks, Scan for Source!file Rqst
00179 00049 RAD50, RAD52 -- Radix-50 Functions for Scout Routines
00183 ENDMK
⊗;
COMMENT ⊗HISTORY
AUTHOR,REASON
021 102100000014 ⊗;
COMMENT ⊗
VERSION 17-1(12) 1-11-74 BY JRL CMU CHANGE COMVER (UNDER NOHACK)
VERSION 17-1(11) 12-8-73 BY JRL REMOVE SPECIAL STANFORD CHARACTERS(WHERE POSSIBLE)
VERSION 17-1(10) 11-24-73 BY RHT %AL% TAKE HRLOI 12, OUT OF S. SEQUENCE
VERSION 17-1(9) 11-24-73 BY RFS RADIX50 TYPE BITS NOT INSTALLED IN RAD5$, RAD5%
VERSION 17-1(8) 11-13-73 BY JRL FORCE PUT TO ALWAYS DO AN ACCESS
VERSION 17-1(7) 11-13-73 BY JRL BUG #PA# GET ADDR OF MPPARM WAS DESTROYING AC C
VERSION 17-1(6) 11-13-73 BY JRL BUG #OZ# FIX GET FOR INSISTED ITEMVARS
VERSION 17-1(5) 11-4-73 BY JRL BUG #OX# LET PUT KNOW ABOUT ? ITEMVARS
VERSION 17-1(4) 10-26-73 BY JRL BUG #OR# A STRING ITEM IS NOT A STRING
VERSION 17-1(3) 10-23-73 BY JRL FEATURE %AG& ITEM OVERLAP STUFF
VERSION 17-1(2) 8-16-73 BY JRL REMOVE REFERENCES TO LEAPSW
VERSION 17-1(1) 8-2-73 BY JRL BUG #NK# TEMPS SHOULD NOT HAVE DISPLAY LEVELS
VERSION 17-1(0) 7-26-73 BY RHT **** VERSION IS 17 ****
VERSION 16-2(31) 7-13-73 BY RHT MODIFY SOUT FOR FNYNAM
VERSION 16-2(30) 7-13-73 BY RHT BUG #MN# A DREADFUL KLUGE TO FIX ACCESS BUG
VERSION 16-2(29) 7-13-73
VERSION 16-2(28) 6-28-73 BY JRL BUG #KA#B IMMEDIATE INSTRUCTIONS NOT USED FOR OR,AND
VERSION 16-2(27) 3-19-73 BY RHT CHANGE SOUT SO STACK SYMBOLS WORK RIGHT
VERSION 16-2(26) 3-13-73 BY JRL REMOVE REFERENCES TO WOM,SLS,GAG,NODIS
VERSION 16-2(25) 2-26-73 BY JRL DO A SKIPE NOEMIT IN XCALLQ
VERSION 16-2(24) 2-6-73 BY JRL MAKE GET HONEST FOR QPARS
VERSION 16-2(23) 1-31-73 BY HJS DISABLE CODOUT, EMITER, AND FBOUT FOR EXPR!TYPE
VERSION 16-2(22) 12-13-72 BY JRL BUG #KS# ADD LOADVR SWITCH
VERSION 16-2(21) 12-13-72
VERSION 16-2(20) 11-30-72 BY JRL MAKE GET HONEST FOR ? ITEMVARS
VERSION 16-2(19) 11-30-72 BY JRL BUG #KQ# IGNORE FIXARRS IN STORA
VERSION 16-2(18) 11-21-72 BY RHT BUG #KH# DEL FORMFX STUFF FROM SIMPROC FORMALS
VERSION 16-2(17) 10-17-72 BY JRL BUG #JR# STRING ITEMVARS NOT STRING
VERSION 16-2(16) 8-29-72 BY KVL ADD CKECK FOR UNTYPED IN PRE
VERSION 16-2(15) 7-17-72 BY RHT BUG #IO# EVAR MESSED UP BY INDEXED STRING TEMP
VERSION 16-2(14) 7-8-72 BY RHT BUG ##I#L# GET ACCESS TO A VARIABLE IN PRE BEFORE INSISTING
VERSION 16-2(13) 6-30-72 BY DCS BUG #IA# PROTECT PTRAC AC OVER FIX, FLOAT, STRING to INTEGER
VERSION 16-2(12) 6-25-72 BY DCS BUG #HX# PARAMETERIZE LIBRARY NAMES (OTHER THINGS)
VERSION 16-2(11) 6-20-72 BY DCS BUG #HU# BETTER TTY PRINTOUT
VERSION 16-2(10) 6-14-72 BY JRL BUG #HS# AN ITEMVAR IS NOT ITS DATUM(MARK).
VERSION 16-2(9) 5-13-72 BY DCS BUG #HF# MAKE GETAC MUCH MORE HONEST
VERSION 15-2(8) 3-25-72 BY DCS BAD ARRAY ADDRESS PROBLEM
VERSION 15-2(7) 3-10-72 BY DCS REPLACE RING, ULINK MACROS WITH ROUTINES
VERSION 15-2(6) 2-9-72 BY DCS BUG #GQ# MAKE ! = UNDERLINE IN RADIX50
VERSION 15-2(5) 2-5-72 BY DCS BUG #GJ# ADD LSTON LISTING CONTROL STUFF
VERSION 15-2(4) 2-1-72 BY DCS ISSUE %ALLOC SPACE REQUESTS IN NEW WAY (SEE GOGOL FOR FORMAT)
VERSION 15-2(3) 1-10-72 BY DCS BUG #FP# FIX A NEGAT BUG
VERSION 15-2(2) 1-7-72 BY DCS BUG #FY# Fix Strvar←INAC-Intvar bookkeeping problem
VERSION 15-2(1) 12-2-71 BY DCS INSTALL VERSION NUMBER
⊗;
COMMENT ⊗DATA for Total (Low-level Code Production) Routines⊗
LSTON (TOTAL)
SUBTTL WIZARD'S DEN -- Generator Called Routines.
BEGIN TOTAL
ZERODATA (TOTAL ROUTINE VARIABLES)
;ACKPNT -- next AC # GETAC should try -- used to distribute
; AC usages among the ACs -- used by GETAC only
?ACKPNT: 0
COMMENT ⊗
FORMFX -- QSTACK descriptor for formal fixups. Until a recursive
Procedure has been completely compiled, it is not known how
many local strings and non-strings will be saved in the runtime
stacks between the stack tops and the formal parameters. Therefore
as instructions accessing parameters are issued, the address
field displacements (assuming 0 locals) are saved, along with
the addresses where they are issued, in the FORMFX stack.
The left half of each entry is the address of the instruction--
the right half is the desired relative displacement (high-order
bit specifies String stack or System stack). After the procedure
is compiled, these entries are QPOPed off and used, along with
the ALOCALS, SLOCALS counts (see PROCED variables) to issue
fixups for these instructions. This Qstack is not used
for non-recursive Procedures
⊗
↑↑FORMFX: 0
?POSSIB: 0 ;TEMP USED BY GETAC WHEN GETTING 2
;TEMPNO -- each temp Semblk allocated is assigned a unique
; number, by incrementing TEMPNO -- a temp Semblk may
; be used several times in the same procedure. See GETTEM
; for description of the mysteries of temps.
?TEMPNO: 0
ENDDATA
COMMENT ⊗Description of Total Routines⊗
DSCR CONV,ACCESS,GET,PUT,STACK,MARK
DES This is the generalized move code. (i.e. called by macro GENMOV).
It consists of several routines which are called in a uniform
fashion. This fashion stipulates that "directive" bits be passed
in the right half of FF which specify modifiers on the operation
of the routine called. Each routine is preceded by a standard
preamble (PRE) and followed by a standard epilog (POST).
Some of the directive bits control PRE and POST. They are:
PAR
PRE:
1. If the GETD bit is on, we do a GETAD first (i.e. use PNT
as the pointer to a symbol table entry, and fill TBITS
and SBITS. This is useful since many of the GENMOV routines
require that TBITS and SBITS be set up.
2. If the PROTECT bit is set, then register D is assumed to have
an accumulator number in it. That accumulator table entry
is "protected". I.e. calls on GETAC and STORA will not affect
the status of anything marked in that accumulator.
3. If the EXCHIN bit is set, we do an EXCHOP.
4. If the INSIST bit is on, type conversions are performed.
These conversions convert from the type specified in the
TBITS word to the type specified in register B (bits
passed to the INSISTer).
5. If the ARITH bit is on, we make sure that the type is
an arithmetic type, performing conversions if necessary.
POST:
1. Put the current contents of the ac's TBITS and SBITS
down in the symbol table entry pointed to by PNT
2. If the REM bit is set, do a REMOP on the thing in PNT
3. If the BITS2 bit is set, we execute MOVE SBITS2,$SBITS(PNT2)
This is useful when an operation on one argument of a binary
op. may change the semantics of another.
4. If the UNPROTECT bit is set, then register D is assumed to
contain an ac number. The ac table entry is unprotected.
5. If the EXCHOUT bit is set, we do an EXCHOP.
NOW FOR A DESCRIPTION OF THE ROUTINES WHICH ACTUALLY USE PRE AND POST:
CONV:
This is really a no-op. It is here for the purposes of calling
the type-conversion routines in PRE, and for the purpose of
making sure that an argument is positive if in an accumulator
(e.g. if we had CVF(-(A+B)), then the result would be in an
accumulator in negated fashion. We now want to push it onto the
stack for the call on CVF. We want to make sure it is REAL and
positive. We use the POSIT bit: GENMOV (CONV,INSIST!POSIT,REAL)
PUT
This issues a store of accumulator mentioned in register D
into the thing described in TBITS, SBITS, PNT. The accumulator
table is updated to reflect this store (i.e. the thing talked about
by PNT is marked as "inac").
If the PNT entry is a string, then D is assumed to be an ac.
into which a HRROI was done, or the SP stack. At any rate, two
POP's are emitted.
ACCESS:
This routine makes sure that we can have access to the entry
mentioned in PNT. That is, if the thing is indexed (result of
an array calculation) and if it requires that some index accumulator
be loaded with a good number, then the load will happen, so
that an effective address can be generated which points at
the thing talked about by PNT.
GET:
This is the generalized "get this entity in an ac" routine.
It makes many checks (i.e. is it already in an ac?) and
finally returns in register D the number of the ac which
has been loaded, and returns in SBITS the updated semantics
information that now reflects the loaded state.
(By the way, to "get" a string means to do HRROI ac,second word
of string.. This is so that POP's can be done later). There
are many modifier bits to this routine:
DBL -- make sure that the ac following the one loaded
is free (for a double ac operation such as IDIV)
INDX -- make sure entity is loaded in an AC which can be
used for indexing (i.e. not 0 or 1. The reason
for including 1 in this is a bit vague -- since
runtime routines often return results in 1, we
try to avoid its use for things thay may have
to be stored as temps).
SPAC -- load this into a special accumulator. That accumulator
number is passed in D.
ADDR -- load the address of this entity, not the value.
POSIT -- make sure the entity is in the ac in positive form.
NEGAT -- make sure in negative form.
NONSTD -- if indxed temp, do not remop it as someone wants
to use it again. (see SWPR for instance). The
problem is not so much remopping, but that GET
likes to make the semantic entries as "inac" on
exit. This fouls up any index calculations that
may have been stored in the PNT entity.
MRK -- when done with the GET, call MARK (see below).
STACK:
The entity mentioned in PNT is stacked on an appropriate
stack. Strings (except arrays) are stacked on the SP
stack, all others on the P stack. ADEPTH or SDEPTH is
updated.
MARK:
This uses the bits in TBITS and SBITS, and the ac number
in D as prototypes for making up a temp descriptor, and
marking the ac full with that temp. Return is a valid
temp descriptor in PNT. If STRING is on in TBITS,
a stacked-string descriptor will be generated
(and of course, no accumulator will be marked).
WARNING ***** MARK masks off some bits in SBITS and
TBITS. PTRAC,CORTMP,INDXED,FIXARR are turned off in SBITS
and the only bits honored by TBITS are:
LPARRAY,SET,ITEM,ITMVAR,INTEGR,FLOTNG,STRING
SID
ACCUMULATORS:
FF -- RIGHT HALF SAVED.
A --THIS MAY BE CHANGED
B --SAVED, I BELIEVE.
C --SAVED, I BELIEVE.
D --OCCASIONALLY FILLED UP (E.G. GET,ACCESS)
TBITS -- THESE ARE THE SEMANTIC BITS -- THEY MAY BE CHANGED.
SBITS -- "
PNT -- " (IN CASE OF MARK OR CONVERSIONS)
LPSA CLOBBERED
USER CLOBBERED
TEMP CLOBBERED
SP --SAVED
SBITS2 --SAVED (modulo what is done in PRE).
TBITS2 --SAVED
PNT2 --SAVED
SEE GENMOV MACRO
⊗;
COMMENT ⊗CONV, PRE, POST -- Type-Conversion routines⊗
MASK←← 0+LPARRAY+SET+LSTBIT+ITEM+ITMVAR+INTEGR+FLOTNG+STRING
;GENMOVE KNOWS ABOUT THESE TYPES
;THIS IS THE PREAMBLE FOR ALL OF THE ROUTINES WHICH
;USE DIRECTIVE BITS TO SPECIFY COERCIONS, EXCHOPS, ETC.
PREMASK ←← GETD!EXCHIN!INSIST!ARITH!PROTECT
↑↑CONV: TRNE FF,PREMASK
PUSHJ P,PRE ;DO EVERYTHING HERE.
TLNE SBITS,NEGAT ;IF NOT NEGAT OR
TRNN FF,POSIT ;NOT NEED THINGS POSITIVE?
JRST POST ;ALL DONE.
JRST GETOPE ;DO THE GET.
PRE: TRNE FF,GETD ;DO A GETAD?
PUSHJ P,GETAD ;YES
TRNE FF,EXCHIN!PROTECT ;EXCHOP ON WAY IN?
JRST [TRNE FF,PROTECT
HRROS ACKTAB(D)
TRNN FF,EXCHIN
JRST .+1
EXCHOP
JRST .+1]
TRNN FF,INSIST!ARITH ;ANY COERCIONS TO DO?
POPJ P, ;NO -- ALL DONE.
PUSHJ P,QTYPCK
;CHECK FOR UNTYPED AND TYPE IF NEC. (SEE ERRORS)
;#IL# 7-8-72 RHT ! GET ACCESS BEFORE YOU CONVERT
PUSHJ P,ACCOP ;GET ACCESS -- YOU MAY NEED IT
TRNE FF,ARITH ;WANT TO BE SURE OF ARITH ARG?
JRST AGET ;YES
LEPPRE: TRNN TBITS,ITEM!ITMVAR ;IF EITHER HAS ITEM BITS ON.
TRNE B,ITEM!ITMVAR ;ALL THESE ARE GOOD GUYS.
JRST [ ;.... ;KEEP GOING.
TRNE B,ITEM!ITMVAR
TRNN TBITS,ITEM!ITMVAR
ERR <ITEM TYPE MISMATCH >,1
POPJ P,] ;THIS IS ALL THE CHECKING!
TRNE B,SET ;A SET OR LIST DESIRED?
JRST [TRNN TBITS,SET ;IF NOT LIST OR A SET CAN'T BE DONE
ERR <TYPE CAN'T BE CONVERTED TO SET OR LIST>,1
TRNE B,LSTBIT ;IF WANTED LIST CAN RETURN
JRST MAKLST ;MAY HAVE TO COPY LIST.
TRNN TBITS,LSTBIT ;IF WANTED SET AND HAVE SET CAN RETURN
POPJ P,
JRST MAKEST] ;WILL HAVE TO CALL CVSET
MOVE USER,B ;COPY OFF.
MOVE TEMP,TBITS
AND TEMP,[XWD SBSCRP,MASK≠(ITEM!ITMVAR)]
ORCB USER,[XWD SBSCRP,MASK≠(ITEM!ITMVAR)]
TDNN TEMP,USER ;ARE ALL BITS IN B ON IN TBITS?
POPJ P, ;THEY MATCH !!
AGOTH:
PUSH P,FF
TRZ FF,-1≠NONSTD ;IN CASE ANY OTHER ROUTINES CALLED.
PUSH P,D
TRNE B,INTEGR+FLOTNG
JRST RESAR ;INSISTS ON ARITHMETIC TYPE
TRNE B,STRING
JRST RESSTR ;INSISTS ON STRING
ERR <GENMOV MAY BE GENERAL, BUT ...>,1
JRST GEMGO ;GO ON ANYWAY
RESSTR: TRNN TBITS,INTEGR ;INSIST ON INTEGER ARGUMENT.
ERR <STRINGS OF NON-INTEGERS?>
TLNN TBITS,CNST ;CONSTANT?
JRST STR1 ;NO
EXCH SP,STPSAV ;GET A GOOD STACK POINTER.
MOVSS POVTAB+6 ;ENABLE FOR STRING PDLOV
PUSH P,$VAL(PNT)
PUSHJ P,PUTCH ;MAKE A STRING (SLOWLY)
POP SP,PNAME+1
POP SP,PNAME
EXCH SP,STPSAV ;AND RESTORE EVERYONE.
MOVSS POVTAB+6 ;RE-ENABLE FOR PARSE PDLOV
PUSHJ P,STRINS ;INSERT A STRING CONSTANT
;THIS DOES A GETAD.
JRST GEMGO ;ALL DONE
STR1: ;PREPARE TO STACK THE INTEGER
PUSHJ P,STACK1 ;DO THE STACK.
SOS ADEPTH ;SINCE THE RUNTIM ROUTINES ADJUST.
MOVEI TEMP,2
ADDM TEMP,SDEPTH ;INCREASE DUE TO CALL.
XCALL <PUTCH> ;FUNCTION CALL
MOVEI SBITS,0 ;START WITH CLEAN DYNAMIC SLATE
JRST TGO ;GO MAKE A TEMP.
AGET: TRNE TBITS,INTEGR+FLOTNG ;IS IT ALREADY ARITHMETIC TYPE?
POPJ P, ;YES
PUSH P,FF
TRZ FF,-1≠NONSTD ; SAVE ALL THIS FOR OTHER
PUSH P,D ; EMBEDDED OPERATIONS
MOVEI B,INTEGR ;THIS FOR THE BENEFIT OF ARSTR.
RESAR: TRNE TBITS,STRING ;HERE TO GET ARITHMETIC RESULTS
JRST ARSTR ;CONVERT FROM STRING
TRNE TBITS,INTEGR+FLOTNG
JRST FIXFL
ERR <THE CONVERSION YOU HAVE REQUESTED ...>,1
JRST TGO ;MAKE A TEMP FOR IT ANYWAY...
ARSTR: TLNE TBITS,CNST ;CONSTANT?
JRST STRCNS
;;#IA# 6-30-72 DCS (3-6) PROTECT PTRAC AC OVER GETAC
HRLI PNT,-1 ;FLAG, ASSUME PROTECTION
HRRZ TEMP,$ACNO(PNT) ;PTRAC AC #, IF ANY
TLNN SBITS,PTRAC ;NEED PROTECTION?
TLZA PNT,-1 ;NO, UNMARK
HRROS ACKTAB(TEMP) ;YES, PROTECT
;;#IA# (3-6)
PUSH P,B ;SAVE TYPE WORD
PUSHJ P,GETAN0 ;NON-0 AC NUMBER
JUMPGE PNT,.+3 ;NEED TO UNPROTECT?
;;#IA# 6-30-72 (4-6)
HRRZ TEMP,$ACNO(PNT) ;YES, DO
HRRZS ACKTAB(TEMP) ; IT
;;#IA# (4-6)
MOVE A,[HRRZ LNWORD] ;CALCULATE LENGTH TO THIS AC
PUSHJ P,STROP ;VIA STROP
HRL B,PCNT ;SAVE PC FOR FIXUP
HRLI C,0
EMIT (<JUMPE USADDR!NORLC>) ;0 IF STRING EMPTY
TLNE SBITS,STTEMP ;NO NEED TO COPY BP IF TEMP STRING
JRST [MOVE A,[ILDB BPWORD]
PUSHJ P,STROP ;SO DO ILDB DIRECTLY
JRST NOCOP] ;AND GET OUT
MOVE A,[MOVE BPWORD] ;GET COPY OF BP
PUSHJ P,STROP ;IN SAME AC
HRL C,D
EMIT (<ILDB USADDR!NORLC>) ;ILDB AC,AC
NOCOP: HRR B,PCNT ;FIXUP WORD
PUSHJ P,FBOUT
MOVEI A,UNDO!REM
PUSHJ P,STROP ;NOW ISSUE SUB IF NECESSARY
PUSHJ P,MARKINT ;MARK INT. RETS RIGHT THING IN PNT
POP P,B
TRNE B,INTEGR ;CONVERT ONLY TO INTEGER?
JRST GEMGO ;YES, OK.
JRST FIXFL ;GO ON FARTHER
STRCNS: HRRZ TEMP,$PNAME(PNT) ;THIS IS THE SAME CODE AS
JUMPE TEMP,.+3 ; SAIL GENERATES TO DO
MOVE TEMP,$PNAME+1(PNT) ; STRING to INTEGER AT
ILDB TEMP,TEMP ; RUNTIME
TRNN B,INTEGR ;DOES HE WANT AN INTEGER CONST
FLOAT TEMP,TEMP ;NO -- ASSUME FLOATING
JRST CONGO ;GO INSERT A CONSTANT.
FIXFL: MOVE USER,[FIX TEMP,TEMP] ;FIX OPERATION?
MOVE TEMP,TBITS ;GET OR OF `SHORT' BITS
OR TEMP,B
TRNE B,INTEGR ;RESULT FIXED?
JRST FIX ;YES
HRLI USER, (<FLOAT TEMP,0>) ;CHANGE TO FLOAT
TLNE TBITS,CNST ;CONSTANT?
JRST FLC
MOVSI A,(<FLOAT>)
TRNN TEMP,SHORT ;SHORT INTEGER BEGIN FLOATED?
JRST UUOGO ;NO, USE UUO
PUSH P,[FSC USADDR!NORLC] ;INSTR TO FLOAT
HRLI C,233 ;ARGUMENT OF FLOAT INSTR
SHRTCV: MOVE TEMP,-2(P) ;FF BITS COMING INTO TOTAL
TRNE TEMP,SPAC ;WAS SPECIFIC AC REQUIRED
TRO FF,SPAC ;YES, RETAIN IT
PUSHJ P,GET ;GET THE THING
POP P,A ;INSTR
JRST JSTEST ;ALREADY KNOW WHAT AC
FIX: TLNE TBITS,CNST ;CONSTANT?
JRST FLC
MOVSI A,(<FIX>) ;CALL FIX
NOEXPO<
TRNN TEMP,SHORT ;CONVERT TO SHORT INTEGER?
JRST UUOGO ;NO
PUSH P,[PDPFIX USADDR!NORLC] ;YES, USE PDP-10 INSTR
HRLI C,233000 ;MAGIC ADDR FIELD FOR PDPFIX INSTR
JRST SHRTCV ;DO SHORT CONVERSION
>;NOEXPO
UUOGO: MOVE TEMP,-1(P) ;DIRECTIVE BITS WORD FROM STACK.
TRNE TEMP,SPAC ;IS HE GOING TO WANT A SPECIAL ONE?
JRST JSTEST ;YES
HRR D,$ACNO(PNT)
;;#IA# 6-30-72 DCS (5-6) PROTECT PTRAC AC OVER GETAC
HRLI PNT,-1 ;FLAG, ETC., SEE PART (3-6)
TLNN SBITS,PTRAC
TLZA PNT,-1
HRROS ACKTAB(D)
;;#IA# (5-6)
TLNN SBITS,INAC ;IF NOT IN AN AC, THEN GET ONE.
PUSHJ P,GETAC
;;#IA# 6-30-72 (6-6)
JUMPGE PNT,.+3
HRRZ TEMP,$ACNO(PNT)
HRRZS ACKTAB(TEMP)
;;#IA# (6-6)
GOTACB:
JSTEST:
DPB D,[POINT 4,A,12] ; STORE AC NUMBER IN INSTRUCTION.
PUSHJ P,EMITER
HRRZ TEMP,FF ;ORIGINAL FF
TRNE TEMP,NONSTD ;IF NON-STANDARD (SEE SWAP OPER),
JRST [POP P,(P) ; DON'T REMOP OR MARK
JRST GEMGO1] ;BUT RETAIN THE AC USED
PUSHJ P,REMOP ;REMOP THE OPERAND.
TGO: HRRZ TBITS,B ;MAKE TBITS CONFORM TO THE DESIRED TYPE
ANDI TBITS,MASK ;MAKE RESULT LOOK LIKE THE REQUESTS
TLZ SBITS,-1≠NEGAT ;CLEAR AWAY THE CHAFF
PUSHJ P,MARK1 ;GO DO A MARK.
JRST GEMGO
FLC: MOVE TEMP,$VAL(PNT) ;HERE FOR A CONSTANT.
XCT USER ;DO THE CONVERSION
CONGO: MOVEM TEMP,SCNVAL ;SET UP FOR SYMBOL TABLE INSERTION
HRRZ TBITS,B ;COME HERE TO INSERT A CONSTANT.
ANDI TBITS,MASK
TLO TBITS,CNST
MOVEM TBITS,BITS ;FOR CONINS
PUSHJ P,REMOP ;ALWAYS REMOVE THE OLD GUY
PUSHJ P,CONINS
GEMGO: POP P,D
GEMGO1: POP P,FF ;AT LAST DO THE POP AND
POPJ P, ;ALL DONE -- FULL SPEED AHEAD.
; NOW FOR THE POSTAMBLE (WE WILL AMBLE THROUGH THE COMPILATION).
POST: MOVEM SBITS,$SBITS(PNT) ;PUT DOWN SEMANTICS WORDS.
MOVEM TBITS,$TBITS(PNT)
TRNN FF,EXCHOUT!BITS2!REM!UNPROTECT ;THESE ARE THINGS TO DO.
POPJ P, ;ALL DONE.
TRNE FF,REM ;REMOP THE THING?
JRST [PUSHJ P,REMOP ;YES
MOVE SBITS,$SBITS(PNT)
JRST .+1]
TRNE FF,BITS2 ;UPDATE SBITS2?
MOVE SBITS2,$SBITS2(PNT2) ;DONE.
TRNE FF,UNPROTECT
HRRZS ACKTAB(D)
TRNN FF,EXCHOUT ;EXCHANGE ON WAY OUT?
POPJ P, ;NO --DONE.
EXCHOP
POPJ P,
COMMENT ⊗PUT⊗
↑↑PUT: TRNE FF,PREMASK ;ANY PREAMBLE TO BE DONE
PUSHJ P,PRE ;YES -- DO IT.
PUSH P,FF ;HERE TO STORE AN ACCUMULATOR INTO
; HAVE PUT ALWAYS DO AN ACCESS
; TLNE SBITS,INDXED ;A DESCRIPTOR
PUSHJ P,ACCOP ;GET ACCESS TO THE TARGET.
TRNE TBITS,STRING ;IF NOT A STRING
TDNE TBITS,[XWD SBSCRP,ITEM!ITMVAR] ;OR NOT REALLY A STRING,THEN
JRST APUT ;USE A MOVEM OR THE LIKE.
MOVE A,[POP BPWORD!LNWORD!SBOP!BPFIRST]
PUSHJ P,STROP ;USE THE STRING OPERATION TO PUT OUT POPS.
CAIE D,RSP ;IF IT WAS NOT THE STACK, THEN
PUSHJ P,CLEARA ;CLEAR OUT THIS ACCUMULATOR ENTRY.
;IT WAS CHANGED WHEN THE POPS WERE DONE ANYWAY.
JRST PUTFIN ;ALL DONE. MY THAT WAS SIMPLE.
APUT: PUSHJ P,CLEARA ;CLEAR OUT THE DESTINATION ACCUMULATOR.
TLNE SBITS,INAC ;IF THE DESTINATION OF THE STORE IS ALREADY
PUSHJ P,CLEAR ;IN AN AC, THEN CLEAR IT OUT.
HRLZI A,(<MOVEM>) ;THE ORDINARY STORE INSTRUCTION.
TLNE SBITS,NEGAT ; BUT IF NEGATED, USE THE OTHER
HRLI A,(<MOVNM>)
;; #OX# TREAT ? ITEMVARS SPECIALLY
TLNE TBITS,MPBIND
JRST [HRR C,D ;SAVE AC NUMBER
GENMOVE (GET,ADDR!INDX)
MOVSS D
HRR D,C ;XWD INDX,,AC
MOVE A,[MOVEM USX+NORLC+NOADDR]
JRST .+1
] ;GO AWAY
;; #OX#
PUSHJ P,EMITER ;AND PUT OUT THE INSTRUCTION.
TLNE SBITS,INDXED ;WE DO NOT WANT TO MARK *********
JRST PUTFN1 ;GO AWAY.
HRRM D,$ACNO(PNT) ;AND THE AC IT IS IN
HRRM PNT,ACKTAB(D) ;IN TWO PLACES.
;THIS UNPROTECTS THIS ACCUMULATOR.
TLOA SBITS,INAC ;AND NOW MARK THE DESCRIPTOR BITS
PUTFN1: TLZ SBITS,NEGAT ;SUBSCRIPTED, NEGAT GETS IN WAY (BELIEVE!)
PUTFIN: POP P,FF ;ALL DONE
JRST POST ;AND FINISH OUT.
COMMENT ⊗ACCESS,GETSDR,GETDR,DISBLK,ZOTDIS--last four only for dis
Call ACCOP when you need to reference a thing and don't know whether you
can get at it in a single instruction (i.e. an indexed thing).
GENMOV(ACCESS) will cause ACCOP to be called for you.
People like GET and STACKOP do it automatically.
⊗
↑↑ACCESS: TRNE FF,PREMASK
PUSHJ P,PRE
PUSHJ P,ACCOP
JRST POST
ACCOP: TDNN SBITS,[XWD INDXED,DLFLDM]; ONLY CARE IF INDEXED OR NEED A DISPLY
POPJ P,
TLNE SBITS,INAC!PTRAC ;IF IN AN AC WE CAN ACCESS IT
POPJ P,
TRNN SBITS,DLFLDM ;IF DISPLAY LEV=0 ONLY CARE ABOUT INDEXED
JRST INXSTF ;NO WORRY ABOUT THE DIAPLAY
LDB TEMP,[LEVPOINT<SBITS>] ;PICK UP DISPLY LEV
TRNE TBITS,STRING ;IS ITT A STRING
JRST [
;; #JR# BY JRL 10-17-72 ITEMVARS,ARRAYS DON'T USE STRING STACK
TDNN TBITS,[REFRNC!SBSCRP,,ITEM!ITMVAR];THESE THINGS DON'T USE
TLNE SBITS,INDXED ;INDEXED? ;STRING STACK
JRST .+1
;; #JR#
JRST GETSDR ;GET STRING DR
]
PUSHJ P,GETDR ;GET A DISPLAY REG LOADED
TRNN SBITS,INDXED ;INDEXED TOO?
POPJ P, ;NO
INXSTF:
;;#JR#
TRNN TBITS,ITEM!ITMVAR
TRNN TBITS,STRING ;ALWAYS NEED STRING GUYS
JRST .+2
;;#JR#
JRST ACMOP
HRRZ TEMP,$VAL(PNT) ; ONLY NEED IT IF NON-ZERO
JUMPE TEMP,CPOPJ ; DISPLACEMENT
ACMOP: TLNE SBITS,PTRAC ;IS IT ALREADY ACCEPTABLE (IN AC)?
POPJ P, ; YES, WHY HAVE WE WORRIED?
PUSH P,D ;HAVE TO SAVE CURRENT AC
PUSH P,A
PUSH P,FF
HRRI FF,INDX ;SO THAT NOTHING NONSTD WILL HAPPEN.
MOVE A,[XWD 40!2!1,ADDR] ;SET NECESSARY BITS
;(SPECIAL BIT, MOVE, GET AC, USE INDXBLE AC, GET ADDR)
PUSHJ P,GETWD
POP P,FF
POP P,A
POP P,D
POPJ P,
COMMENT⊗
DSCR GETSDR,GETDR
DES ROUTINES TO LOAD UP STRING (ARITHMETIC) DISPLAYS
LOADS UP LPSA WITH THE AC NO TO USE & FIXES UP ACTAB,DISTAB,&DISLST
PARM TEMP=LEVEL DESIRED
SID MANGLE TEMP,LPSA
STORES LEVEL IN LSDRLV, STORES DR # IN LSDRNM (LH FOR SDR & RH FOR DR)
⊗
;;#MN# 7-13-73 FIX ACCESS PROBLEM
ZERODATA(EMITTER DATA)
LSDRLV: 0 ;SEE ABOVE
LSDRNM: 0
ENDDATA
↑↑GETSDR:
HRLM TEMP,LSDRLV ;REMEMBER LEVEL OF STRING REQUEST
HLRZ LPSA,DISTAB(TEMP) ;DO WE HAVE IT ALREADY
HRLM LPSA,LSDRNM ;IF SO REMEMBER
;;#MN#
JUMPN LPSA,CPOPJ ;YES
PUSHJ P,GETDR ;GET THE P-DISPLY
PUSH P,FF ;WHAT A PITY WE MIGHT HAVE JUST POPPED
PUSH P,A ;BUT THIS IS QUICKER IN THE LONG
PUSH P,B ;RUN THAN MESSING WITH FLAGS
PUSH P,C ;
PUSH P,D
TRZ FF,DBL ;ONLY ONE AC
HRL D,LPSA ;USE P-DR AS INDEX
MOVE B,TEMP ;WE WILL NEED THIS
HRLI C,2 ;DISPL OF 2
PUSHJ P,GETAN0 ;GET AN AC FOR DISPLY
EMIT (<MOVE ,USX!USADDR!NORLC>) ;LOAD THE DR
HRLM D,DISTAB(B) ;ENTER INTO DISPLAY TABLE
PUSHJ P,DISBLK ;SET UP MOST OF BLOCK
MOVEI TEMP,STRING ;
HRRZM TEMP,$TBITS(LPSA) ;MAKE TYPE RIGHT
MOVSS $VAL(LPSA) ;FIX UP AND MASK
;;#MN# !
HRLM LPSA,LSDRNM
JRST RETSEQ ;GO POP STUFF & RETURN
↑↑GETDR:
;;#MN# !
HRRM TEMP,LSDRLV
HRRZ LPSA,DISTAB(TEMP) ;PICK UP THE PUTATIVE REGISTER
;;#MN# !
HRRM LPSA,LSDRNM
JUMPN LPSA,CPOPJ ;IF THERE,RETURN
PUSH P,FF
PUSH P,A
PUSH P,B
PUSH P,C
PUSH P,D
PUSH P,TEMP ;GETDR MUST SAVE IT
TRZ FF,DBL ;ONLY ONE AC
HRRZI B,1(TEMP) ;NEXT LEVEL DEEPER
GDR1: HRLZ D,DISTAB(B) ;PICK IT UP
CAIN D,0 ;IS IT LOADED
AOJA B,GDR1 ;NO
HRLI C,1 ;SET TO SELECT STATIC LINK
MOVE A,[<MOVE 0,USX!NORLC!USADDR>]
GDR2: PUSHJ P,GETAN0 ;THIS BETTER LEAVE LH(D) ALONE -- IT DOES
PUSHJ P,EMITER ;UP ONE STATIC LINK
SOS B ;BACK A LEVEL
HRRM D,DISTAB(B) ;SAY WE HAVE IT
PUSHJ P,DISBLK ;TO DO STUFF FOR DISPLAY BLOCK&ACKTAB
CAMN B,(P) ;IS THIS THE ONE WE WANT
JRST GDR4 ;YES
GDR3: HRL D,D ;USE AS INDEX PERHAPS
HRR D,DISTAB-1(B) ;NEXT AC BACK
TRNE D,-1 ;IS IT THERE
SOJA B,GDR3 ;YES
JRST GDR2 ;NO--FETCH IT
GDR4: HRRZ LPSA,D ;AC NO OD DISPLY
;;#MN# !
HRRM LPSA,LSDRNM ;REMEMBER NUMBER
POP P,TEMP
RETSEQ: POP P,D
POP P,C
POP P,B
POP P,A
POP P,FF
POPJ P, ;RETURN
COMMENT ⊗
DSCR DISBLK
DES THIS PROCEDURE SETS UP DISPLAY SEMBLK STUFF & UPDATES ACKTAB
IT SETS LPSA TO POINT ATE THE NEW SEMBLK
THE BLOCK IS SET UP FOR A LPSA TYPE SEMBLK
PARM B = DISPLAY LEBEL
D= ACNO OF DISPLAY REG
⊗
↑↑DISBLK:
GETBLK ;GET A BLOCK
HRRM D,$ACNO(LPSA) ;SAVE AC NO
HRRM B,$ADR(LPSA) ;LEVEL GOES HERE
SETOM TEMP
HRLZM TEMP,$VAL(LPSA) ;SETS UP ANDING MASK
MOVE TEMP,[XWD PTRAC!INAC!DISTMP,INTEGR]
HRRZM TEMP,$TBITS(LPSA) ;$TBITS WORD
HLLZM TEMP,$SBITS(LPSA) ;$SBITS WORD
PUSHJ P,RNGDIS ;PUT IT ON DISLST LIST
HRRZM LPSA,ACKTAB(D) ;MARK AC FULL OF IT
POPJ P, ;RETURN
COMMENT ⊗
DSCR ZOTDIS
DES this procedure will wipe out your current display
PARM None
SID LPSA,TEMP used
⊗
↑↑ZOTDIS:
PUSH P,D ;SAVE
PUSH P,A
MOVE A,CDLEV ;CURRENT DISPLAY LEVEL
ZDIS.1: SOJL A,ZDIS.2
HRRZ D,DISTAB+1(A)
CAIE D,RF ;DONT ZONK RF
CAIN D, ;DONT DO ANYTHING IF NOT THERE
SKIPA
PUSHJ P,STORZ
HLRZ D,DISTAB+1(A)
CAILE D,
PUSHJ P,STORZ
SETZM DISTAB+1(A)
JRST ZDIS.1
ZDIS.2: POP P,A
POP P,D
POPJ P,
COMMENT ⊗GET
GENMOV(GET) generally invokes this routine.
It has many purposes, depending on the entity to be "getted".
Briefly, however, it loads an AC with the thing one
wants in order to store or compute using the entity in
question. For strings, it loads a string address
with the left half negative (for popping). For
INDXED guys (with ADDR turned on), it loads
the result of the index calc to an ac if it was not
there. For regular variables, it simply picks them
up if they are not in an AC. The bits
ADDR, INDX, DBL, POSIT, NEGAT, and MARK
may be used to modify the action of GETOPE.
⊗
↑↑GET: TRNE FF,PREMASK ;ANYTHING TO DO??
PUSHJ P,PRE
TRC FF,INSIST!NONSTD ;IF NO MARKING TO BE DONE, AND
TRCE FF,INSIST!NONSTD ; A TYPE CONVERSION WAS DONE,
JRST GETOPE
;; #OZ# (1 OF 1) PRE DOESN'T DO A GET OF ITEMS OR ITEMVARS
TRNE B,ITMVAR!ITEM ; PRE DID NOT DO A GET
; IF ITEMVARS OR ITEMS
JRST GETOPE
;; #OZ#
HRRZ TEMP,B ; (COMPARE INSISTED TYPE WITH
CAIE TEMP,(TBITS) ; ACTUAL TYPE), THEN DON'T GET
JRST POST ; AGAIN
↑GETOPE:
PUSHJ P,ACCOP ; ESTABLISH ACCESS TO THE EFFECTIVE ADDRESS.
COMMENT ⊗ IF STTEMP, NO MORE WORK NECESSARY
(ASSUME STRING IS ON) ⊗
TLNN SBITS,STTEMP
JRST GETOPC
TRNN FF,ADDR ;MUST GO THRU WITH IT IF ADDR
JRST TMPRET
COMMENT ⊗ USE LEFT HALF OF A TO HOLD SOME EXTRA BITS:
1 -- NEED AN AC (GETAC)
2 -- DO A MOVE OF SOME SORT
4 -- DO A MOVN
10 - MAKE IT A HRRO
20 - MAKE IT A HRROI, FOR STRING INDXED GUYS (SEE BELOW)
40 - SPECIAL ACCOP BIT, SEE GETRET BELOW
NEED EXTRA CHECKS IF ENTITY IS ALREADY IN AN AC
⊗
GETOPC: HRLZI A,3 ;ASSUME NEED A MOVE
TRNE FF,SPAC ;UNLESS AC # PROVIDED,
TLZ A,1 ; ASSUME AC NEEDED
TLNN SBITS,INDXED ;IF ¬INDEXED, THEN TURN OFF NONSTD.
TRZ FF,NONSTD ;SO AS NOT TO FOUL UP.
NOSPAC: TLNN SBITS,INAC!PTRAC;IF IN AC, HAVE TO BE SURE IT'S RIGHT
JRST STCHK ; IF NOT, MUST CHECK
; FOR STRINGS (HAVE TO LOAD)
Comment ⊗ INAC -- if DBL or INDX or SPAC,
find out if thing can stay in this AC -- otherwise
must get another. ⊗
; FIRST CHECK SPAC GUYS
TLZ A,1!2 ;ASSUME NOTHING YET
TRNN FF,SPAC ;PROVIDED WITH SPECIFIC AC?
JRST DBCHK ; NO, CHECK DBL WANTED
HRRZ TEMP,$ACNO(PNT) ;GET CURRENT AC #
CAIN TEMP,(D) ;DID WE LUCK OUT (SAME ONE)?
JRST SBSCHK ;YES, GO CHECK SPECIAL INDXED THING
;DCS 8/16/70 IF SPAC AC BEING REPLACED,
; STORE AND CLEAR WHAT'S IN IT
SKIPLE ACKTAB(D) ;PROTECTED OR NOTHING THERE?
PUSHJ P,STORZ ; NO, GET RID OF IT
;DCS 8/16/70
TLO A,2 ;WILL HAVE TO DO A MOVE
JRST WPCHK1 ;AND MAKE SEMANTICS CHANGES
; IF DBL IS ON, SEE IF NEXT AC IS FREE, SET UP TO MOVE IF NOT
DBCHK:
HRR D,$ACNO(PNT) ;GET CURRENT AC NUMBER
TRNN FF,DBL ;WELL
JRST IDXCHK ;NO DBL REQUESTED
SKIPGE ACKTAB+1(D) ;NEXT ONE NOT USABLE?
JRST WIPCHK ; CANNOT BE USED, MAKE SEMANTIC CHANGES
HRRI D,1(D) ;STORE THE NEXT
PUSHJ P,STORZ
HRRI D,-1(D) ;RESTORE AC #
IDXCHK: TRNE FF,INDX ;NEED INDX?
TRNE D,-2 ; AND NOT IN ONE ALREADY?
JRST SBSCHK ;OK, 'TWOULD SEEM
Comment ⊗ If AC # is being changed (INAC and NEEDAC or SPAC and MOVE)
clear right half of ACKTAB(AC), but first be sure nothing will be
wiped out ⊗
WIPCHK: TLO A,1!2 ;HAVE TO MOVE IT
WPCHK1: HRRZ TEMP,$ACNO(PNT) ;IT IS HERE CURRENTLY
SKIPGE ACKTAB(TEMP) ;WAS THIS AC PROTECTED?
ERR <DRYROT --AC CLOBBER>,1
SETZM ACKTAB(TEMP) ;"STORR" (STORL DONE BEFORE)
Comment ⊗ for STRING INDXED quantities (or non-STRING with ADDR)
(guaranteed INAC by now) requiring a displacement,
a "HRROI" FXTWO (or MOVEI)must be done --
"HRRO" ("MOVE") with ADDR would yield a no-op
⊗
SBSCHK: TLNN SBITS,INDXED ;TEST THE CONDITONS
JRST POSN ; NOT INDEXED
HRRZ TEMP,$VAL(PNT) ;≠0 DISPLACEMENT?
JUMPE TEMP,POSN ; NO DISPLACEMENT, NO PROBLEM
;; #OR# ! A STRING ITEMVAR IS NOT A STRING
TRNN TBITS,ITMVAR!ITEM ; A STRING ITEM IS NOT A STRING
TRNN TBITS,STRING ;INDXED STRING?
JRST CHKNUM ; NO, CHECK GET!ADDR FOR NUMERIC ARRAY
TRZ FF,ADDR ;JUST IN CASE
TLO A,2!20 ;MOVE, HRROI, NO ADDR
JRST POSN
CHKNUM: TRZE FF,ADDR ;WANT THE ADDRESS ALL TOGETHER?
TLO A,100!2 ; YES, MOVE, MOVEI
JRST POSN
Comment ⊗ for strings, we must do a HRRO with ADDR
turned ON (except for SBSCRP strings) ⊗
STCHK: TRNE FF,SPAC ;STORE AC IF SPAC
PUSHJ P,STORZ
TRNE TBITS,STRING ;STRING, NOT SBSCRP?
TDNE TBITS,[XWD SBSCRP,ITEM!ITMVAR] ;NOT REALLY A STRING?
JRST POSN
TDO A,[XWD 2!10,ADDR] ;DO A "HRRO" ADDR
; IF (POSIT(A) and NEGAT(SBITS)) or (NEGAT(A) and ¬ NEGAT(SBITS)) MUST
; DO SOMETHING ABOUT IT
POSN: TRNE FF,POSIT ;FIRST CONDITION
TLNN SBITS,NEGAT
JRST CHNGAT ; UNSATISFIED
TLZ SBITS,NEGAT ;NO LONGER NEGAT
TLO A,2!4 ;DO "MOVN"
JRST CHKDX ;GO CHECK INDEXED
CHNGAT: TRNE FF,NEGAT ;SECOND CONDITION
TLNE SBITS,NEGAT
JRST CHKDX ; UNSATISFIED
TLO SBITS,NEGAT ;NOW NEGAT
TLO A,2!4 ;DO A "MOVN"
CHKDX: TLNE SBITS,INDXED ;IF INDXED, NOT STRING, NOT ADDR, BE
TRNE TBITS,STRING
JRST ADRCK ;DOES NOT NEED A HRRO, HRROI
TRNN FF,ADDR
TLO A,2 ; SURE SOME SORT OF MOVE GETS DONE
ADRCK: TRNE FF,ADDR ;NOW COPY THIS INTO A
TRO A,ADDR ;LIKE ALL CPA'S.
GETWD: TRNN FF,NONSTD ;THE NON-STANDARD TYPE WILL
;**ALWAYS** GET AN AC.
TLNE A,1 ;NEED AC?
PUSHJ P,GETAC ; YES, GOT IT
TLNN A,2 ;NEED TO MOVE?
JRST [TLNN SBITS,INAC!PTRAC ;STRIVE TO PUT BITS BACK RIGHT
JRST TMPRET
TLNE SBITS,INDXED
JRST IDXRET
JRST GETRET] ;BEST AS POSSIBLE THE SAME AS ON ENTRY
MOVE TEMP,A ;SAVE BITS SO YOU CAN TEST THEM
PUSH P,A ;SAVE LH BITS
HRLI A,(<MOVE>) ;ASSUME "MOVE"
TLNE TEMP,4 ;MOVN?
HRLI A,(<MOVN>) ; YES
TLNN TEMP,20!10 ;HRRO OR HRROI?
JRST NOHRRO ;NO
TRO A,FXTWO
HRLI A,(<HRRO>)
TLNE TEMP,20 ;ETC.
HRLI A,(<HRROI>)
NOHRRO:
PUSH P,PNT
TRNE TBITS,ITMVAR
TLNN TBITS,MPBIND ;IF NOT ?ITEMVAR
JRST NOTMPP ;CONTINUE
TRZ A,ADDR
;; JRL FOLLOWING WAS MISTAKENLY A HRRI
HRLI A,(<MOVEI @>)
TRNE TEMP,ADDR ;ADDR REQUESTED
;; JRL FOLLOWING WAS MISTAKENLY A HRRI
HRLI A,(<MOVE>)
JRST EMTMOV ;EMIT THE MOVE
NOTMPP: TLNE TEMP,100 ;FOR GET ADDR
HRLI A,(<MOVEI>)
TRO A,IMMOVE ;IF POSSIBLE
TRNE TBITS,ITEM ;OH MY GOSH AROODIES.
JRST [TLNN TBITS,FORMAL!SBSCRP
MOVE PNT,$VAL2(PNT) ; IT WILL BE AN INTEGER....
JRST .+1]
EMTMOV: PUSHJ P,EMITER
POP P,PNT ;IN CASE OF ITEM.
POP P,A
TLNE TBITS,MPBIND
JRST [TLO SBITS,INAC
TRNN A,ADDR ;ADDR?
JRST ALLRET ;NO.
;; #PA#!(1OF 2) SAVE C ON CALL TO GET
PUSH P,C
HRLZI C,20 ;INDIRECT BIT
EMIT <TLZN ,USADDR!NORLC>
;; #PA#!(2 OF 2) RESTORE C
POP P,C
EMIT <MOVEI ,0>
TLZ SBITS,INAC
JRST TMPRET] ;DON'T REMEMBER ADDR IS IN AC
GETRET: TRNE FF,NONSTD ;SPECIAL CASE OF PRESERVING INDXD TEMPS
JRST [MOVE SBITS,$SBITS(PNT) ;RESTORE OLD MARKING.
JRST TMPRT1] ;AND FINISH OUT.
TLZ SBITS,PTRAC!INDXED!INAC ;START FROM SCRATCH
TLNN A,20!40!100 ;INAC MARKING?
JRST STDRET ; YES, DO IT
IDXRET: TLO SBITS,PTRAC!INDXED;KEEP INDXED BITS
TLNN A,20!100 ;HRROI (MOVEI) THING?
JRST ALLRET ; NO
TLZ TBITS,OWN
HLLZS $VAL(PNT) ; NO DISPL ANYMORE
JRST ALLRET
STDRET: TDNN TBITS,[XWD SBSCRP,ITEM!ITMVAR] ;NOT REALLY A STRING?
TRNN TBITS,STRING ;KEEP BITS OFF IF STRING
TLO SBITS,INAC
ALLRET: HRRM PNT,ACKTAB(D) ;UPDATE SEMANTICS AND
HRRM D,$ACNO(PNT) ; ACKTAB
TMPRET: MOVEM SBITS,$SBITS(PNT) ;IF ACCOP, THIS WILL BE NECESSARY
TMPRT1: TRNN FF,MRK ;DOES HE WANT A MARK?
JRST POST ;ALL DONE.
PUSHJ P,REMOP ;AFTER ALL THAT?
JRST MARK1 ;AH, WELL
COMMENT ⊗STACK -- Issue Instrs. to Stack Anything on Approp. Stack⊗
↑↑STACK: TRNE FF,PREMASK ;ANY TO DO?
PUSHJ P,PRE
PUSHJ P,STACK1
TRNN FF,MRK ;HAS HE ASKED FOR A MARK?
JRST POST ;FINISH OUT.
JRST MARK1 ;AND DO A MARK.
STACK1: PUSH P,FF ;SAVE
TRNN SBITS,DLFLDM ;DOES HE LIVE IN THE STACK?
TLNE SBITS,INDXED
PUSHJ P,ACCOP ;GET ACCESS.
TDNE TBITS,[XWD SBSCRP,ITEM!ITMVAR] ;ALWAYS STACK ARRAYS ON P-STACK
JRST ASTACK ; NO MATTER WHAT
TRNN FF,ADDR ;MUST BE A CALL BY REF.
TRNN TBITS,STRING ;STRING STACK?
JRST ASTACK ;NO -- ARITHMETIC
TLNE SBITS,STTEMP ;IF STTEMP and INUSE,
; ALREADY STACKED, DON'T DO AGAIN
JRST MARTK ;JUST MARK AND QUIT
MOVEI D,RSP ;TO AVOID CLOBBERING CORE.
MOVE A,[PUSH RSP,STAK!BPWORD!LNWORD!ADOP!REM]
TRNE FF,REM ; IF REM BIT IS ON IN FF THEN DON'T REMOP IN
TRZ A,REM ; STROP1 SINCE POST WILL DO IT
PUSHJ P,STROP1 ;THIS IS REALLY EASY. DO TWO PUSHES.
;; FOLLOWING WAS ERRONEOUSLY TO MARTK THUS REMOPING BLOCK TWICE
;; #ML ACTUALLY NEED TO LOAD SBITS AGAIN SHOULD BE MARTJ
JRST MARTJ ;AND NOW MARK THINGS.
ASTACK: TLZN SBITS,NEGAT ;ARE THINGS CURRENTLY NEGATIVE?
JRST OKPO ;NO
TLNN SBITS,INAC!PTRAC
ERR <DRYROT -- STACK NEGAT IN CORE?>,1
HRL C,$ACNO(PNT)
EMIT (MOVNS USADDR!NORLC!NOUSAC)
MOVEM SBITS,$SBITS(PNT);FOR THE EMITER.
OKPO: TLNE TBITS,MPBIND ;A ?ITEMVAR
JRST [TRNE FF,ADDR ;ADDRESS REQUIRED?
ERR <DRYROT -STACK ADDR ? ITEMVAR>
TLNE SBITS,PTRAC!INAC
JRST .+1
PUSH P,D
PUSHJ P,GETAC
EMIT <MOVEI @,>
PUSHJ P,MARKINT
POP P,D
JRST .+1]
HRLZI A,(<PUSH RP,>)
TRNE FF,ADDR ;COPY THIS BIT.
TRO A,ADDR
TRO A,NOUSAC ;WE HAVE SPECIFIED IT.
PUSHJ P,EMITER ;PUT OUT THE PUSH.
AOS ADEPTH ;SINCE WE USED THE PSTACK
MARTK: TRNN FF,REM ;IF REM BIT IS ON THEN DON'T DO REMOP SINCE POST
; WILL DO IT
PUSHJ P,REMOP ;REMOVE THE THING YOU'RE STACKING
MARTJ: MOVE SBITS,$SBITS(PNT);GET ITS BITS BACK FOR THE REST OF THIS
MARTH: POP P,FF ;RESTORE
POPJ P,
COMMENT ⊗MARK, MARKINT, MARKME -- Mark Semblk with Correct Temp Semantics
This marks the AC (D) with a temp descriptor of type in SBITS, TBITS⊗
↑↑MARK: TRNE FF,PREMASK ;
PUSHJ P,[TRNE FF,657777
ERR <MARK>,1
JRST PRE]
PUSHJ P,MARK1
JRST POST ;ALL DONE.
MARK1: ANDI TBITS,MASK ;WANT ONLY THE TYPE BITS (NOT FORMAL,ETC.)
;;#NK# ! (1 OF 2) TEMPS SHOULD NOT HAVE DISPLAY LEVELS
TDZ SBITS,[CORTMP!PTRAC!INDXED!FIXARR,,DLFLDM]
;;#HS# JRL AN ITEMVAR IS NOT ITS DATUM
TRNE TBITS,ITMVAR!ITEM
JRST .+3
;;#HS#
TRNE TBITS,STRING ;IF STRING TYPE, THEN
JRST STMARK
TLO SBITS,INAC!ARTEMP!INUSE ;SINCE HE MAY NOT HAVE SET THEM.
TLZ SBITS,STTEMP
HRRE LPSA,ACKTAB(D) ;PICK UP TEMP DESCIRIPTOR
JUMPLE LPSA,NOTEM ;IF NO TEMP OR REMOPPED TEMP
MOVE USER,$SBITS(LPSA) ;GET SEMANTIC BITS
TLNN USER,INUSE ;A TEMP?
JRST REMM ;NO
TLNN USER,CORTMP ;A CORE TEMP?
JRST USOLD ;NO -- USE THE TEMP THAT IS THERE.
TLNE USER,INAC ;IS IT STILL IN THE ACCUMULATOR?
PUSHJ P,STORA ;YES --STORE IT.
SKIPA
REMM: PUSHJ P,CLEARL ;DO THE REMOP
NOTEM: PUSHJ P,GETTEM ;GET A NEW TEMPORARY
USOLD: HRRM LPSA,ACKTAB(D) ;INSERT IN AC TABLE RIGHT HALF
HRRM D,$ACNO(LPSA) ;AND THE LOGICAL INVERSE.
MARKT: HRRZM LPSA,PNT ;
SETZM $VAL(PNT)
MARTS: POPJ P,
STMARK: TLO SBITS,STTEMP ;IN CASE IT SKIPS AND NOONE ELSE DID
TLZ SBITS,ARTEMP
HRRZ LPSA,PNT ;IN CASE STRTMP NOT CALLED
TLNN SBITS,INUSE ;ALREADY HAS A TEMP?
PUSHJ P,STRTMP ;GET A STRING TEMP.
JRST MARKT
DSCR MARKINT, MARKME
DES THESE ARE ROUTINES TO HELP YOU CALL "MARK"
MARKINT -- ALWAYS MARKS A VANILLA INTEGER, RETURNS DESCR. IN PNT,SBITS,TBITS.
MARKME -- YOU SPECIFY TBITS, SBITS=0 IS ASSUMED
⊗;
↑↑MARKINT: MOVEI TBITS,INTEGR ;MARK AN INTEGR,
↑↑MARKME: HRRI FF,0
SETZ SBITS,
JRST MARK1
COMMENT ⊗INCOR -- Issue Code to Clear this Entity from ACs⊗
DSCR INCOR
DES makes sure that the entity mentioned in PNT,TBITS,SBITS is really
in core. If not, the AC entry for that entity is cleared.
The updated Semantics bits are returned in SBITS.
⊗;
↑↑INCOR:
TLZN SBITS,INAC!PTRAC ;GONE?
POPJ P, ;ALL DONE!
PUSH P,D ;SAVE THIS.
HRRZ D,$ACNO(PNT) ;PICK UP RELEVANT AC.
PUSHJ P,STORZ
POP P,D
JRST GETAD ;ALAS, SINCE STORZ WILL CHANGE THINGS.
COMMENT ⊗REMOPs, CLEARs -- Remove Temps, ACs, from Use⊗
DSCR REMOP,REMOPA,REMOPL,REMOP2
DES These are the REMOP routines. They say, in effect, "I am
finished with this argument. If it was a temp descriptor, then I
am really finished, and the temp may be returned to the pool of
such temps. If it was a simple variable or constant, etc. then no
action is taken.
PAR The differences among the routines are only in the call form:
REMOP -- PNT has pointer to entity.
REMOPL -- LPSA has pointer to entity
REMOPA -- D has AC number of entity.
REMOP2 -- PNT2 has pointer to entity.
SID AC'S USED: LPSA,TEMP,USER
⊗;
↑REMOP2: MOVE LPSA,PNT2
JRST REMOPL
↑REMOPA: SKIPA LPSA,ACKTAB(D) ;REMOP BY ACCUMULATOR NUMBER
↑REMOP: MOVE LPSA,PNT ;OH WELL.
↑REMOPL: TRNN LPSA,-1
POPJ P, ;NONE THERE.
MOVE TEMP,$SBITS(LPSA);THE STANDARD REMOP
TLNN TEMP,STTEMP!ARTEMP!INUSE ;A REAL TEMP?
JRST STCNST ;NO, CHECK IF A STRING CONSTANT
DELAL: MOVSI USER,INUSE!STTEMP!INAC!PTRAC!NEGAT!FIXARR ;TURN THESE OFF
ANDCAM USER,$SBITS(LPSA) ;IN MEMORY.
HRRZ USER,$ACNO(LPSA) ;GET THE AC IT WAS IN
TLNN TEMP,INAC!PTRAC ;WAS IT IN AN AC?
JRST CTCHK ;NO -- ALL DONE.
SKIPGE ACKTAB(USER) ;YES --TURN IT OFF.
ERR <DRYROT -- REMOP>,1
SETZM ACKTAB(USER)
CTCHK: TLNE TEMP,INUSE ;If this was still an alive temp, and
TLNE TEMP,CORTMP ; was not a CORTMP, thus contains no fixups
POPJ P, ; or anything, we can release it to free
PUSH P,LPSA ; storage. Otherwise, leave it on the TTEMP
PUSHJ P,BLKFRE ; list (where it MUST be), and forget it.
POPJ P,
STCNST: MOVE TEMP,$TBITS(LPSA) ;
TLNE TEMP,CNST ;
TRNN TEMP,STRING ;
POPJ P, ; RETURN IF NOT A STRING CONSTANT
MOVE TEMP,$PNAME(LPSA) ; CHECK IF TRYING TO REMOP NULL STRING WHICH IS
TRNN TEMP,-1 ; ONLY STRINS'ED ONCE
POPJ P, ; YES, DON'T REMOP
SOSLE TEMP,$VAL2(LPSA) ; DECREMENT REFERENCE COUNT AND GET OUT IF NOT
POPJ P, ; ZERO
JUMPE TEMP,.+2 ; ZERO COUNT?
ERR <DRYROT REMOP:STCNST> ;
SKIPN $VAL(LPSA) ; USED IN PRELOAD?
SKIPE $ADR(LPSA) ; USED IN FIXUP?
POPJ P, ; YES, RETURN
PUSHJ P,URGCST ; REMOVE FROM STRING CONSTANT RING
PUSHJ P,URGSTR ; REMOVE FROM STRING RING
PUSH P,PNAME ; SAVE PNAME AND PNAME+1 (OK ON P STACK SINCE NO
PUSH P,PNAME+1 ; GARBAGE COLLECTION CAN HAPPEN)
HRROI TEMP,$PNAME+1(LPSA) ; GET STRING DESCRIPTOR FOR HASH LOOKUP SO THE
POP TEMP,PNAME+1 ; STRING CAN BE REMOVED FROM THE HASHED SYMBOL
POP TEMP,PNAME ; TABLE
PUSH P,TBITS ; SAVE AC'S WHICH SHASH WILL DESTROY
PUSH P,A ;
PUSH P,B ;
PUSH P,C ;
PUSH P,D ;
PUSH P,PNT ;
PUSH P,LPSA ;
MOVE LPSA,STRCON ; USE STRING HASH TABLE
PUSHJ P,SHASH ;
MOVE B,HPNT ; INSTRUCTION TO LOAD FIRST IN CONFLICT LIST
XCT B ; FIRST IN CONFLICT LIST INTO LPSA
HRRZ PNT,(P) ; THE ONE WE ARE LOOKING FOR
MOVEI A,LPSA ;
SCOMLP: HRRZ TEMP,(A) ; CANDIDATE?
JUMPE TEMP,ERRSTC ; NOT THERE - ERROR
CAMN TEMP,PNT ;
JRST SFNDIT ;
MOVE A,TEMP ; CHAIN DOWN CONFLICT LIST
JRST SCOMLP ;
SFNDIT: HRRZ TEMP,(TEMP) ; NEXT IN LIST
HRRM TEMP,(A) ; CHAIN AROUND DELETED ELEMENT
TLO B,2000 ; CHANGE FROM LOAD TO STORE
XCT B ;
FREBLK (PNT) ;
POP P,LPSA ; RESTORE AC'S
POP P,PNT ;
POP P,D ;
POP P,C ;
POP P,B ;
POP P,A ;
POP P,TBITS ;
POP P,PNAME+1 ;
POP P,PNAME ;
POPJ P, ;
ERRSTC: ERR <DRYROT AT REMOP>,1 ;
DSCR CLEAR,CLEARL,CLEARA
DES These are routines to clear an entry in the AC table (ACKTAB)
That is, all memory of what is in the AC is lost. The difference
among the routines is the call form:
PAR CLEAR -- PNT has pointer to entity to be "cleared"
If it turns out not to be in an AC, no action is taken.
CLEARL -- LPSA has pointer; same deal.
CLEARA -- D has AC number to be cleared.
SID AC'S USED: LPSA,TEMP
⊗;
↑CLEAR: MOVEI LPSA,(PNT) ;CLEAR OUT AN AC TABLE ENTRY.
↑CLEARL: MOVE TEMP,$SBITS(LPSA) ;SEE IF IT IS IN AN AC.
TLNN TEMP,INAC!PTRAC ;IF NOT -- ALL DONE.
POPJ P, ;DONE.
MOVE TEMP,$ACNO(LPSA) ;AC IT IS IN.
SETZM ACKTAB(TEMP) ;AND ZERO THE ENTRY.
JRST CLR1 ;FINISH OUT.
↑CLEARA: MOVEI LPSA,0 ;
EXCH LPSA,ACKTAB(D) ;ZERO AC TABLE ENTRY.
CLR1: MOVSI TEMP,INAC!PTRAC!NEGAT
TRNE LPSA,-1 ;ANYTHING THERE? (DCS -- 8/16/70)
ANDCAM TEMP,$SBITS(LPSA) ;TURN THESE OFF IN MEMORY.
POPJ P,
COMMENT ⊗STROP -- Bit-Driven String Operation Code Generator⊗
DSCR STROP
DES This routine is willing to do lots of twiddling on strings.
It knows about reference strings, etc.
PAR A is an instruction for the EMITTER, with some bits in
it to say what things should be done with this instruction.
Bits in A: bpword -- issue the instruction for
the byte pointer word.
lnword -- or for the length word.
bpfirst -- issue the byte pointer inst. first.
adop -- this is an instruction which adds to stack.
sbop -- this is an instruction which subs from stack.
undo -- so a SUB SP,X22 at end.
rem -- do a remop when done.
stak -- used internally.
bpinc -- byte pointer instruction is in c(rh)
PNT,TBITS,SBITS -- semantics of string.
D -- accumulator to use for ac field of op.
Thus, it must be RSP if that stack is to be used.
⊗;
↑STROP: CAIN D,RSP ;IF THE STACK,
TRO A,STAK ;THEN MARK AS SUCH.
DPB D,[POINT 4,A,12] ;SAVE IN AC FIELD OF INSTRUCTION.
PUSHJ P,ACCOP ;AND GET ACCESS TO THE ROUTINE.
;THIS UPDATES SBITS IN CORE.
STROP1: PUSH P,ACKTAB(D) ;PROTECT.
SETOM ACKTAB(D)
PUSH P,D ;SAVE AC.
TLNN TBITS,REFRNC ;THE HARD CASE.
JRST OPPP1 ;
PUSH P,A ;SINCE GETOPE DOES NOT PRESEVE.
HRRI FF,ADDR!INDX
PUSHJ P,GETOPE ;GET THE ADDRESS OF THE BP WORD IN AN AC.
;THIS UPDATES SBITS IN CORE.
SETZM ACKTAB(D) ;WE DO NOT WANT TO SEE THIS AGAIN.
HRLZS D ;READY FOR INDEXING.
POP P,A
OPPP1: TLNE SBITS,STTEMP ;IF STACKED, THEN NEED
HRLI D,RSP ;THE STACK
HRRI FF,(A) ;SAVE BITS.
TRNE FF,BPFIRST ;IF BYTE POINTER WORD FIRST, DO IT
PUSHJ P,BP
PUSHJ P,LN ;NOW THE LENGTH
TRNN FF,BPFIRST
PUSHJ P,BP
TRNE FF,UNDO
TLNN SBITS,STTEMP ;IF UNDO AND A STACKED STRING.
JRST OP2 ;
PUSHJ P,SUBIT
OP2: POP P,D ;RESTORE.
POP P,ACKTAB(D)
TRNE FF,REM ;IF REMOP ASKED FOR.
JRST REMOP
POPJ P, ;ALL DONE.
DSCR SUBIT
DES Emits a SUB SP,[XWD 2,2], and subtracts two from SDEPTH.
⊗;
↑SUBIT: PUSH P,A
MOVE A,X22 ;SUBTRACT TWO FROM THE STACK.
PUSH P,PNT
PUSHJ P,CREINT
EMIT (<SUB RSP,NOUSAC>) ;THEN ISSUE THE SUBS.
PUSHJ P,REMOP ;JUST IN CASE
POP P,PNT
MOVNI A,2
ADDM A,SDEPTH ;UPDATE COUNT.
POP P,A
JRST GETAD ;RESTORE TBITS,SBITS.
BP: TRNN FF,BPWORD ;ONLY IF ASKED FOR.
POPJ P,
PUSH P,A ;SAVE
TRNE FF,BPINC ;IF ANOTHER INSTRUCTION AROUND.
DPB C,[POINT 9,A,8] ;IN INSTRUCTION PARTS.
HRRI A,NOUSAC!FXTWO ;TENTATIVE BITS TO EMITER.
TLNN SBITS,STTEMP ;IF ON STACK OR
TLNE TBITS,REFRNC ;BUT IF THIS CASE, THEN
TRC A,FXTWO!NORLC!USX!USADDR
HRLI C,0 ;WITH NO DISCPLACEMENT.
PUSHJ P,EMITER
POP P,A
JRST FINBP
LN: TRNN FF,LNWORD ;ONLY IF ASKED
POPJ P,
HRRI A,NOUSAC
TLNN SBITS,STTEMP ;IF TEMP OR
TLNE TBITS,REFRNC ;REFERENCE, THEN MUST USE
TRO A,NORLC!USX!USADDR ;INDEXING ETC.
HRLI C,-1 ;ANO THIS TIME A DISPLACEMENT.
PUSHJ P,EMITER
FINBP: TRNE FF,ADOP!SBOP ;PREPARE TO ADJUST STACK.
TRNN FF,STAK ;ONLY IF ON STACK.
POPJ P, ;NONE.
TRNE FF,ADOP
AOSA SDEPTH
SOS SDEPTH ;OUR BOOKKEEPING DONE,
POPJ P, ;WE DEPART.
COMMENT ⊗GETTEM, etc. -- Temp Semblk Allocators⊗
DSCR GETTEM,GETCRTMP,STRTMP
DES Routines for getting temp descriptor Semblks. The list of
free temps is searched for an appropriately free one. If found,
a masked form of TBITS, and a masked form of SBITS are stored
in the Semblk for this temp. A pointer to it is returned in LPSA
INCL more descriptions about temps, their numbers, how they're
moved, kept track of, deleted, depend on procedures, etc.
GETTEM -- get a non-core temp
STRTMP -- get a String temp (i.e. turn on the STTEMP bit in SBITS)
GETCRTMP -- get a core temp.
SID AC'S USED: USER,LPSA,TEMP
⊗;
STRTMP: TLOA SBITS,INUSE!STTEMP
↑GETTEM: TLO SBITS,INUSE!ARTEMP ;TURN ON TEMP BITS.
;;#NK# ! (2 OF 2) TEMPS SHOULD NOT HAVE DISPLAYS LEVELS
TDZ SBITS,[CORTMP,,DLFLDM]
GETBLK ;GET A NEW BLOCK
GTT1: MOVEM SBITS,$SBITS(LPSA)
ANDI TBITS,MASK
MOVEM TBITS,$TBITS(LPSA) ;GOOD BITS IN MEMORY
POPJ P, ;NOTHING ELSE TO DO
↑GETCRTMP: ;GET A CORE TEMP
SKIPA LPSA,TTEMP
STRG: LEFT ,%RVARB,NOFF
MOVE TEMP,$SBITS(LPSA)
TLNE SBITS,CORTMP
TLOE TEMP,INUSE
JRST STRG
DDRET: MOVSI SBITS,INUSE!CORTMP!ARTEMP
JRST GTT1 ;FINISH OUT AS ABOVE.
NOFF: PUSHJ P,GETTEM
AOS TEMP,TEMPNO ;INCREMENT TEMP ID NO
MOVEM TEMP,$PNAME(LPSA) ;STORE IN $PNAME FOR ADCON AND SCOUT
SETZM $ADR(LPSA) ;AND ZERO THE FIXUP.......
PUSHJ P,RNGTMP
JRST DDRET
COMMENT ⊗GETAC, GETAN0 -- AC Allocators⊗
DSCR GETAC,GETAN0
DES These are the "get a free AC routines".
PAR FF(rh) -- two modifier bits:
DBL -- get a double AC (i.e. next one free too)
INDX -- get an indexable AC (not 0 or 1 -- 1 is avoided since
Procedures tend to return values in 1).
RES in D is returned the free (first free) AC number
Note that no ACKTAB marking has been done yet, so the AC
need not be used.
GETAN0: same as GETAC, but INDX is autimatically turned on.
AC'S USED: TEMP,LPSA
⊗;
↑GETAN0: TRO FF,INDX ;HERE IF YOU DON'T WANT TO SET THE BIT
↑GETAC:
HRR D,ACKPNT ;LAST AC USED
SETOM ACKPNT ;CLEAR IT
SETZM POSSIB ;MASK OF POSSIBILITIES
MOVNI TEMP,20 ;NUMBER OF AC'S TO SEARCH
;;#HF# 5-13-72 DCS RETURN OLDEST AVAILABLE AC IF NONE FREE, FIX DBL
GET1: AOJG TEMP,GET7 ;For each AC, starting with the one
ADDI D,1 ; after the last allocated, and wrapping
TRZ D,777760 ; around to 0 (2 if GETAN0), if the AC
TRNE FF,INDX ; is not protected (ACKTAB(AC)<0),
TRNE D,-2 ; record the (oldest) first one seen in
SKIPGE LPSA,ACKTAB(D) ; ACKPNT -- if the entry is free (0),
JRST GET1 ; try to terminate. Otherwise, continue
SKIPGE ACKPNT ; looking for a free one.
HRRZM D,ACKPNT
TRNN LPSA,-1
JRST GET4
JRST GET1
; ONE FREE ONE EXISTS -- JUST RECORD IF DBL (NEED TWO)
GET4: TRNN FF,DBL ;If only one AC is needed, it's number
JRST DSTORZ ; is in D.
GET3: MOVEI LPSA,1 ;Otherwise, record its number in the
LSH LPSA,(D) ; bit array POSSIB. This is not the
IORM LPSA,POSSIB ; most efficient method, but it allows
JRST GET1 ; the fun below.
; LIST EXHAUSTED -- TAKE WHAT WE COULD GET
GET7: TRNE FF,DBL ;If two were needed, we must work
JRST GET9 ; harder.
; TAKE A DISPLAY TEMP FIRST
SKIPE DISLST ;ONLY ANY GOOD IF HAVE SOME
SKIPG LPSA,CDLEV ;CURRENT DISPLAY LEV
JRST GET7.1
HRRI D,1 ; COULD NEVER BE ZERO OR 1
GET7.2: SKIPE DISTAB(D)
JRST GET7.3 ;THIS THING HAS AN AC
AOS D ;TRY THE NEXT ONE UP
SOJG LPSA,GET7.2
ERR <DRYROT AT GETAC> ;YOU REALLY BLEW IT, SAM
GET7.3: MOVE LPSA,DISTAB(D) ;PICK IT UP
TLNE LPSA,-1 ;USE STRING DISPLY IF WE CAN
MOVSS LPSA ;US STRING -HURRAH
CAIN LPSA,RF ;
JRST GET7.1 ;IF RF, THEN NO GO
HRR D,LPSA ;WE CAN GRAB THIS ONE
SKIPG ACKTAB(D)
ERR <GETAC GRABBED SAFE AC -- DRYROT AND WORMS>
JRST DSTORZ ;RECORD IT, CLEAR IT OUT
GET7.1:
; NO DISPLAY TEMP, CLEAR SOMETHING ELSE OUT AND USE IT.
HRR D,ACKPNT ;Use the first one recorded, which
JRST STORZ ; is also the oldest found
; WE NEED TWO -- TRY FOR TWO UNUSED IN A ROW
GET9: MOVE LPSA,POSSIB ;If any two in a row were free,
LSH LPSA,1 ; the AND of the bits and 2*bits
AND LPSA,POSSIB ; will yield a bit for each pair.
JUMPE LPSA,G10 ;No bits implies no pairs.
FSC LPSA,231 ;The FSC shifts the first match
LDB LPSA,[POINT 4,LPSA,8] ; to a normalized position, and
MOVEM LPSA,ACKPNT ; records its index in the exponent
HRR D,LPSA ; field.
POPJ P,
G10: HRRI D,21 ;As a last resort, take the first
G11: SUBI D,2 ; two unprotected ACs available.
TRNE D,777000 ;If none are found, complain bitterly.
ERR <DRYROT AT DBL GETAC> ;This could be improved by
SKIPL LPSA,ACKTAB(D) ; looking for the oldest pair, and/or
SKIPGE ACKTAB-1(D) ; a pair with one free AC, but at
JRST G11 ; this point, we're sort of beyond
JUMPE LPSA,.+2 ; caring.
PUSHJ P,STORZ ;Store the second, if it needs it.
SUBI D,1 ;This is the result.
DSTORZ: HRRZM D,ACKPNT ;Allocating this one. Now go make
JRST STORZ ; sure it's ready for new action.
;;#HF#
COMMENT ⊗AC Store routines -- BOLSTO, FORSTO, STORIX, GOSTO, STORZ⊗
DSCR BOLSTO
DES Special Boolean store. It does not remove from ACs any
of the arguments to the Boolean compare.
PAR PNT and PNT2 must point to Semantics of the two arguments.
RES All other ACs are stored. The Semantics of the parameters
are not necessarily guaranteed over the call, since either
may have been marked for storing.
SEE STORZ, which it calls for each AC cleared
⊗;
↑BOLSTO: PUSH P,[PUSHJ P,[
HRRZ TEMP,LPSA
CAIE TEMP,(PNT2)
CAIN TEMP,(PNT)
POPJ P,
JRST STORZ]] ;DO TURN OFF ACSAME FOR THESE GUYS.
; THIS STORZ IS NEEDED BECAUSE A PARTICULAR BOOLEAN MAY LOOK LIKE:
; MOVE 4,I
; SKIPN J
; JRST FOO1
; MOVE 4,J+K
; SKIPE GH
; JRST SHIT
;FOO1: ..... HERE THE COMPILER THINKS J+K IS IN 4, WHERE I MIGHT BE!!!
;
JRST GG0
DSCR FORSTO
DES Special AC dumper for FOR Loops. This protects the index
AC from being cleared. Other variables are not cleared, just
stored if temps.
PAR PNT and PNT2 should point to anything to be preserved
over this operation (e.g. FOR I← <EXP> STEP .... want to preserve
I and the Semantics of <EXP> from storing before the test.
SEE STORA, which it calls for each AC stored.
⊗;
↑FORSTO: PUSH P,[PUSHJ P,[HRRZ TEMP,ACKTAB(D) ;FOR FOR LOOPS.
CAIE TEMP,(PNT)
CAIN TEMP,(PNT2)
POPJ P,
;DCS -- 8/16/70
PUSHJ P,STORA ;STORE IT FOR SURE
JUMPE LPSA,NSBSC ;NOTHING TO CLEAR
;;#MU# RHT 6-25-73 I THINK THE FOLLOWING DISTINCTION IS POINTLESS
; MOVE TEMP,$TBITS(LPSA) ;IF AN INAC ARRAY,
; TLNE TEMP,SBSCRP ;CLEAR IT, BECAUSE WILL
;;#MU#
JRST CLEARL ;STILL BE ASSUMED INAC AT
NSBSC: POPJ P, ; LOOP TOP OTHERWISE
]] ;DCS -- 8/16/70
JRST GG0
DSCR STORIX
DES "Store" all INTERNALs and EXTERNALs, i.e. forget that
they are in ACs.
⊗;
↑STORIX: PUSH P, [PUSHJ P,[
HRRZ LPSA,ACKTAB(D)
JUMPE LPSA,CPOPJ ;NOTHING THERE.
MOVE LPSA,$TBITS(LPSA)
TLNE LPSA,INTRNL!EXTRNL
JRST CLEARA
POPJ P,]]
JRST GG0
DSCR ALLSTO
DES Dump all ACs in the most permanent of ways. Do not
retain any marking of the AC's at all.
SEE STORZ, which it calls for each AC gronked.
⊗;
↑ALLSTO: PUSH P,[PUSHJ P,STORZ] ;TO CLEAR INAC" BITS.
SKIPA
DSCR GOSTO
DES Store any AC's marked with temps (as opposed to variables).
Leave the AC markings as they are.
⊗;
↑GOSTO: PUSH P,[PUSHJ P,STORA]
GG0: PUSH P,D
MOVEI D,20 ;D, WHO WILL HAVE A COUNT
G1: SOJL D,ALLD ;COUNT DOWN
SKIPG LPSA,ACKTAB(D) ;DO WE HAVE A STORE TO DO?
JRST G1 ;NO -- GO AHEAD
XCT -1(P) ;EXECUTE STORING ROUTINE.
JRST G1
ALLD: POP P,D
POP P,(P) ;THROW AWAY
POPJ P, ;AND RETURN
DSCR STORZ
DES "Store" this AC and wipe out the ACKTAB entry -- clear
INAC-type SBITS in the Semantics which were there.
PAR AC # in D
SEE STORA,CLEARA routines, which it calls
⊗;
↑STORZ: PUSHJ P,STORA
JRST CLEARA
COMMENT ⊗ STORA -- main AC-storing subr. -- called by above⊗
DSCR STORA
DES Stores temp results that are in a specified AC into
a core temp. If a temp exists in that AC, an appropriate core
temp is found, and the Stoe is EMITted.
Then the SBITS word in the Semantics is updated to
reflect the "In Core" status (e.g. CORTMP bit, fixup
chain addr, etc.) The fixup chain may have originated
in another temp entry, but was moved here to avoid searching
up the Semantic stack for all who refer to this temp and
changing the addresses of the entry they point to. WHAT????
PAR D contains AC # affected.
SID LPSA, TEMP used
⊗;
↑STORA: SKIPG LPSA,ACKTAB(D)
POPJ P, ;NOTHING THERE.
PUSH P,SBITS
MOVE SBITS,$SBITS(LPSA);GET SEMANTIC BITS.
TLNN SBITS,INAC!PTRAC ;IF NOT IN AC, THEN TROUBLE
ERR <STORA A THING NOT IN AC>,1
;; #KQ BY JRL (11-30-72) IGNORE FIXARS
TLNN SBITS,FIXARR ;A FIXARR SHOULDN'T GET STORED
TLNN SBITS,ARTEMP!DISTMP ;OTHERWISE A NOOP
JRST ZER
PUSH P,PNT
PUSH P,A
MOVEI PNT,(LPSA)
;BUG TRAP
HRRZ TEMP,$ACNO(PNT) ;THIS IS THE AC IT THINKS ITS IN.
CAIE TEMP,(D) ;THE SAME
ERR <STORA>,1
TLNE SBITS,DISTMP ;DISPLAY????
JRST ZERDR ;YES
TLNE SBITS,CORTMP ;CAN WE PUT IT WHERE WE PUT IT BEFORE?
JRST DEP ; YES (USUALLY ONLY HAPPENS WHEN SOME
; BUG PROVOKES IT --LIKE MISSING REMOP)
SKIPA LPSA,TTEMP ;PREPARE TO SEARCH TEMP LIST
TEML: LEFT ,%RVARB,NOFND ;GO DOWN TEMP LIST
MOVE TEMP,$SBITS(LPSA)
TLZE TEMP,INUSE ;NEED ONE NOT IN USE
JRST TEML
TLZN TEMP,CORTMP ;AND IN CORE
JRST TEML ;REALLY AN ERROR
MOVE TEMP,$ADR(LPSA)
MOVEM TEMP,$ADR(PNT) ; HO HO.
MOVE TEMP,$PNAME(LPSA) ;ID NUMBER OF THIS CORTMP
MOVEM TEMP,$PNAME(PNT) ;SO ADRINS AND SCOUT DON'T GET CONFUSED
PUSHJ P,URGTMP ;REMOVE FROM RING
FREBLK () ;THE OLD ONE
JRST DEP1
NOFND: SETZM $ADR(PNT) ;WITH ZERO FIXUP
;; #JRL ALWAYS GIVE CORTMPS ID NO.
AOS TEMP,TEMPNO ;CORTMP ID
MOVEM TEMP,$PNAME(PNT)
;; #JRL
DEP1: MOVE LPSA,PNT
PUSHJ P,RNGTMP ;PUT ON RING
DEP: MOVSI SBITS,CORTMP!INUSE!ARTEMP
IORB SBITS,$SBITS(PNT) ;INDICATE THE NEW STATUS
TURNOF: MOVSI LPSA,INAC!PTRAC!NEGAT ;TEMP NO LONGER IN AC
ANDCAM LPSA,$SBITS(PNT)
HRRM D,(PNT)$ACNO ;RECORD THE AC NUMBER
HRLZI A,(<MOVEM>)
TLNE SBITS,INDXED ;A CALCULATED SUBSCRIPT?
TRO A,ADDR ;YES -- DO NOT STORE INDIRECT.
TLNE SBITS,NEGAT ;IS THE AC AROUND NEGATIVELY?
HRLI A,(<MOVNM>) ;YES
;; #MD# ONLY STORE RIGHT HALF OF PTRAC
TLNE SBITS,PTRAC
HRLI A,(<HRRZM>) ;ONLY RIGHT HALF, IN CASE LATER AN
;INDIRECT MOVE IS DONE
PUSHJ P,EMITER
;NOTE THOUGH THAT NEGAT MAY STILL
;BE ON. THIS MAY BE DANGEROUS.
MOVEM SBITS,$SBITS(PNT)
ZRET: POP P,A
POP P,PNT
ZER: POP P,SBITS
POPJ P, ;RETURN
ZERDR: MOVE A,$VAL(PNT) ;ZEROING MASK
HRR LPSA,$ADR(PNT) ;PICK UP DISPLAY LEVEL
ANDM A,DISTAB(LPSA) ;ZERO APPROPRIATE SIDE OF DISTAB WORD
HLLZS ACKTAB(D) ;ZONK THE ACKTAB ENTRY
MOVE LPSA,PNT
PUSHJ P,URGDIS ;UNLINK FROM DISPLAY VARB RING
FREBLK (PNT)
JRST ZRET
SUBTTL CODE EMITTER
COMMENT ⊗EMITER -- Descriptions of Routine and Control Bits⊗
DSCR EMITER -- code emitting routine.
DES From input parameters and symbol table information,
generate a word of real live code.
PAR
A -- OPCODE in LH, bits in RH:
NOUSAC←←400000 ;DON'T USE D(RH) AS AC #
USCOND←←200000 ;USE C(RH) AS 3 BITS OF CONDITION
USADDR←←100000 ;USE C(LH) AS DISPLACEMENT PART
USX ←← 40000 ;USE D(LH) AS INDEX REG
NORLC ←← 20000 ;RELOCATE NOT!
IMMOVE←← 10000 ;IF OPERAND CONSTANT, LOAD IT ANY WAY POSSIBLE
INDRCT←← 4000 ;INDIRECT ADDRESSING REQUIRED
JSFIX ←← 2000 ;JUST DO A FIXUP (DON'T GET SEMANTICS).
NOADDR←← 1000 ;NO EFFECTIVE ADDRESS PART
ADDR ←← 400 ;WE WANT THE ADDRESS OF THIS ENTITY
FXTWO←← 100 ;USE SECOND FIXUP WORD
C -- DISPLACEMENT (if provided) in LH, condition bits in RH
D -- Index number in LH, AC number in RH (both optional)
PNT -- symbol table pointer, if required
RES Code is written, RELOC bit is set to final value;
Formal fixup list (FORMFX) has been updated, if necessary.
SID All Ac's are saved except TEMP and LPSA.
⊗;
BIT2DATA (EMITTER)
INDIR ←← 20 ;THE INDIRECT BIT!!
;PNTROP ←← 200 ;THIS OPERATION WILL DO POINTER INDEXING
; (PURELY LOCAL BIT, BUT DON'T SEND IT IN)
IMMED ←← 1000 ;THE IMMEDIATE BIT (FOR SOME THINGS).
↑XCALLQ:
SKIPE NOEMIT
POPJ P,
PUSH P,C ;LITTLE ROUTINE
HRL C,PCNT ;FOR CALLING LIBRARY ROUTINES.
EXCH C,(A) ;FIXUP INTO LIBRARY TABLE.
EMIT (<PUSHJ RP,NOUSAC!USADDR>)
POP P,C
POPJ P,
COMMENT ⊗ EMITER Routine⊗
↑EMITER:
SKIPE NOEMIT ; GET OUT IF NO CODE IS TO BE EMITTED (I.E.
POPJ P, ; EXPR!TYPE)
PUSH P,A ;SAVE THOSE THINGS WHICH MIGHT CHANGE
PUSH P,C
PUSH P,D
PUSH P,TBITS
PUSH P,SBITS
TRZ A,PNTROP ;ASSUME NO POINTER OP
;;# # DCS 3-25-72 Eliminate bad array address problem
;;# # When [0,0,0]-word of array (location known, no fixup) falls
;;# # on reladr 0 of .REL file, CODOUT will mistake the 0 addr field
;;# # for end of fixup chain, will inhibit RELOC -- want RELOC in this
;;# # case. A bad fix, should be more generally solved.
TLO FF,RELOC!FFTMP1 ;AND RELOC (FFTMP1 FOR CODOUT 0-TEST)
;;# #
TRNE A,USADDR ;ADDR IN C(LH)?
JRST EAC ;YES, BYPASS SEMANTICS TESTING
TLZ FF,RELOC ;NOW ASSUME NO RELOCATION
HRRZS C ;CLEAR DISPLACEMENT FLD -- C(LH)
TRNE A,NOADDR ;IS THERE AN ADDRESS FLD AT ALL?
JRST EAC ;NO, FINISH UP
TRNE A,JSFIX
JRST EVAR ;GO DO A FIXUP
; NOW GET SEMANTICS AND DISPATCH TO CORRECT ROUTINE TO OUTPUT INSTR
MOVE SBITS,$SBITS(PNT)
MOVE TBITS,$TBITS(PNT)
;; #JR# BY JRL 10-17-72 A STRING ITEM IS NOT A STRING
TRNE TBITS,ITEM!ITMVAR
TRZ TBITS,STRING ;FORGET ABOUT STRING TYPE FOR ITEMS
;; #JR#
NOSBS: TRNN TBITS,PNTVAR ;IF PNTVAR OR INDXED OR
TLNE SBITS,INDXED ; REFERENCE FORMAL,
TRO A,PNTROP ;INDICATE A POINTER OPERATION
TLNE TBITS,REFRNC
TRO A,PNTROP
TRNE A,ADDR ;IF ADDR and PNTROP, TURN OFF BOTH
TRZE A,PNTROP ;(THE IMMEDIATENESS
TRZ A,ADDR ; OF ADDR CANCELS THE INDIRECTNESS OF PNTROP
TLNE TBITS,SBSCRP ;ELIMINATE FXTWO IF
TRZ A,FXTWO ; ARRAY NAME
;;#FP# 1-10-72 DCS (1-2)
TLNE SBITS,INAC ;IN ACCUMULATOR?
JRST EINAC
;;#FP#
TLNE TBITS,FORMAL ;FORMAL PARAMETER (ACTUAL)?
JRST EFORM ;
TRNE A,PNTROP ;INDIRECTNESS DESIRED?
JRST EPNT
;;#FP# 1-10-72 DCS (2-2)
TLNE SBITS,PTRAC ;IN ACCUMULATOR? (WAS INAC TOO)
JRST EINAC
;;#FP#
TRNE A,ADDR ;SHOULD WE CONSIDER CONSTANT IMMED?
JRST EVAR ;NO
TLNE TBITS,CNST ;NUMERIC CONSTANT?
TRNE TBITS,STRING ;
JRST EVAR ; NO
ECONST:
SKIPE OPDUN ;NEVER OPTIMIZE USER INLINE CODE
JRST EVAR ; BUT REFER TO MEMORY
MOVE TEMP,$VAL(PNT) ;GET VALUE
TRNN A,IMMOVE ;IMMEDIATE MOVE REQUESTED?
JRST OPCON1 ; NO, TEST LH0
HRLI A,(<MOVE >) ;ASSUME MOVEI
TLC TEMP,-1 ;TEST LEFT HALF -1
TLCN TEMP,-1 ;IS IT?
JRST [HRL C,TEMP ;YES, SET UP
HRLI A,(<HRROI>) ; INSTR
JRST EAC] ;AND EMIT IT
TRNE TEMP,-1 ;RIGHT HALF ZERO?
JRST OPCON1 ; NO
MOVSS TEMP ;YES, SWAP HALVES
TLO A,4000 ; AND TURN ON MOVSI BIT
OPCON1: TLNE TEMP,-1 ;LEFT HALF ZERO?
JRST EVAR ;NO
HRL C,TEMP
LDB TEMP,[POINT 9,A,8] ;GET OP-CODE
SUBI TEMP,200 ;ONLY OPCODES IN RANGE <MOVE> (200)
JUMPL TEMP,EVAR ; TO <OR> (434) WILL
CAILE TEMP,234 ; BE CONSIDERED
JRST EVAR
PUSH P,USER
IDIVI TEMP,=36 ;WORD # TO TEMP, BIT # TO USER
MOVE TEMP,OPBTS(TEMP);SOME BITS
TABCONDATA (OPCODE BITS TABLE FOR EMITER OPTIMIZER)
OPBTS: 421042004000 ;BIT ON IF
000000104000 ;CORRESPONDING OPCODE
776000000000 ;CAN BE IMMEDIATE
; OLD WORD OBPTS+3 ;REPLACED (6-27-73)
; 001040000000
;; #KAB INCORRECT AND MISSING OBPTS ENTRIES
000000004200
401040000000
;; #KAB#
ENDDATA
LSH TEMP,(USER) ;THE RIGHT ONE
POP P,USER
JUMPGE TEMP,EVAR ;CAN'T OPTIMIZE, CODE WRONG
CAML A,[CAM] ;THE COMPARES ARE MADE
CAML A,[JUMP] ; IMMEDIATE BY TURNING OFF
TLOA A,IMMED ; THE 10000 BIT, ALL OTHERS
TLZ A,10000 ; BY TURNING ON THE 1000 BIT
JRST EAC ;PUT OUT OPTIMIZED INSTR
EPNT: HRRE TEMP,$VAL(PNT) ;GET DISPLACEMENT IF ANY
SUBI TEMP,1 ;ASSUME STRING AND ¬FXTWO
TRZN A,FXTWO ;IF FXTWO OR
TRNN TBITS,STRING ; ¬STRING,
ADDI TEMP,1 ;REVERSE ASSUMPTION
HRL C,TEMP ;GET TO DISPLACEMENT PLACE
TLNE SBITS,PTRAC ;POINTER IN AC?
JRST EACX ; YES
TLNE C,-1 ;MAKE INDIRECT
ERR <DRYROT AT EPNT>,1 ;UNLESS WE WANTED A DISPLACEMENT
TRO A,INDRCT ;MAKE IT INDIRECT
JRST EVAR ;GO DO FIXUPS
EACX: HRL D,$ACNO(PNT) ;USE AC AS INDEX
TLNE TBITS,OWN ;IF ARRAY NAME COMES INTO IT,
;;# # DCS 3-25-72 Bad array address problem.
TLC FF,RELOC!FFTMP1;RELOCATABLE, SHOUDN'T 0-TEST IN CODOUT
;;# #
TROA A,USX ;DENOTE THAT IT SHLD BE DONE
EINAC: HRL C,$ACNO(PNT) ;INAC, GET ACNO AS DISPL.
JRST CHKIMM ;SEE IF ADDR IS ON
EFORM: TRO A,USX ;WILL NEED TO USE A STACK AS INDEX
HRRZ TEMP,$ADR(PNT) ;GET DISPL FROM STACK TOP
TLNE TBITS,REFRNC ;REFERENCE PARAM?
JRST REFPRM ; YES
VALPRM: TRNN TBITS,STRING ;STRING
JRST REFPRM ;NO
SKIPN SIMPSW
TRNN SBITS,DLFLDM ;IF SIMPLE OR DL 0 THEN DO IT THE OOLD WAY
JRST USERSP
LDB LPSA,[LEVPOINT(SBITS)]; PICK UP LEVEL
HLL D,DISTAB(LPSA) ;PICK UP REGISTER
TLNN D,17
;;#MN# 7-13-73 THE FRIDAY 13 ACCESS KLUGE
JRST [
PUSH P,TEMP
HLRZ TEMP,LSDRLV ;MAYBE THE THING IS STILL AROUND
CAIE TEMP,(LPSA)
ERR <DRYROT AT EFORM FOR STRING> ;BETTER NOT BE 0
HLL D,LSDRNM ;GET THE OLD THING
POP P,TEMP
JRST .+1]
;;# #
TRZE A,FXTWO ;IF SECONG WORD
SUBI TEMP,1 ;FIX IT
MOVN TEMP,TEMP
HRL C,TEMP ;USE THIS DISPL
JRST CHKIMM ;GO CHECK
REFPRM: TLNN TBITS,SBSCRP ;IF SUBSCRIPTED AND
JRST .+3 ; REFERENCE,
TLNE TBITS,REFRNC ;
TRZ A,PNTROP ;DO NOT GO INDIRECT.
TRZE A,PNTROP ;WANT TO GET VALUE?
TRO A,INDRCT ; YES, GO INDIRECT, FIND ON RP STACK
LDB LPSA,[LEVPOINT(SBITS)];PICK UP DISPLY LEVEL
CAIE LPSA,0 ;IF HAVE A DISPLAY
JRST USEDRF ;USE IT
MOVE LPSA,TPROC ;PICK UP PROC ID
HRRZ LPSA,$SBITS(LPSA);PICK UP RH OF SBITS FOR PROC
ADDI LPSA,1 ;WANT LEVEL OF FORMLS
XOR LPSA,SBITS ;ALL THIS IS A FANCY TEST TO SEE IF THIS PROC'S
TRNE LPSA,LLFLDM ;IS IT THE SAME
ERR <INACCESSABLE FORMAL> ;NO
SKIPN SIMPSW ;BETTER BE SIMPLE PROC
ERR <DRYROT AT EPNT -- SIMPLE?> ;YOU FUCKED UP
USERP: HRLI D,RP ;MARK THIS STACK
ADD TEMP,ADEPTH ;TOTAL ARITH STACK DEPTH
JRST MAKFRM ;GO CREATE FORMAL REF INSTR
USERSP: HRLI D,RSP
ADD TEMP,SDEPTH
TRZE A,FXTWO ;SECOND WORD?
SUBI TEMP,1 ;YES, DON'T GO SO FAR
MAKFRM: MOVNS TEMP ;NEGATIVE STACK DISPLACEMENT
HRL C,TEMP ;USE THIS DISPLACEMENT
;;#KH# RHT (11-21-72) DELETED LARGE HUNKOF LEFT OVER STUFF FROM FORMFX
JRST CHKIMM ;FINISH OUT
USEDRF: HRL D,DISTAB(LPSA) ;PICK UP DISPLAY REGISTER
TLNN D,-1 ;WAS IT LOADED
;;#MN# FRIDAY 13 JULY
JRST [
PUSH P,TEMP
HRRZ TEMP,LSDRLV
CAIE TEMP,(LPSA) ;OLD LEVEL THERE???
ERR <DRYROT AT EFORM>,1;NO
POP P,TEMP
HRL D,LSDRNM
JRST .+1 ]
;;# #
MOVN TEMP,TEMP ;NEGATE DISPL
SUBI TEMP,1 ;SINCE RF IS ONE MORE AWAY
HRL C,TEMP ;USE IT
JRST CHKIMM ;GO FINISH UP
EVAR:
TLO FF,RELOC ;NOW ASSUME RELOC AGAIN
TRNE A,JSFIX ;IF JUST WANT A FIXUP
JRST USECR ;THEN THATS ALL YOU GET
TLNE SBITS,CORTMP ;IS IT A CORE TEMP
JRST [ ;YES
SKIPN RECSW ;IF NOT RECURSIVE PROC THEN
JRST USECR ;USE A CORE LOCN -- NO DR NEEDED
MOVE LPSA,CDLEV ;USE THIS LEVEL
JRST USED.1 ;NO LDB ALLOWED
]
TRNE SBITS,DLFLDM ;STACK VAR?
JRST USEDR ;YES
USECR:
HRL C,$ADR(PNT) ;ADDR OR LAST FIXUP
DCDFX: TRNN A,JSFIX
TRNE TBITS,FORWRD!INPROG ;MUST FIXUP IF EITHER IS ON
JRST DOFIX
TLNN SBITS,FIXARR ;DON'T FIXUP IF FIXARR ON
TRNE TBITS,PROCED!LABEL ;ELSE ONLY IF NEITHER OF THESE
JRST DONTFX
JRST DOFIX
USEDR: LDB LPSA,[LEVPOINT<SBITS>] ;GET DISPLAY LEVEL
USED.1: HRL D,DISTAB(LPSA) ;USE DISPLY REG
TRNE TBITS,STRING ;UNLESS STRING
JRST [
;#IO# RHT 7-17-72 ATTEMPT TO USE STR DR FOR A INDEXED TEMP
TLNE SBITS,INDXED ;DONT IF RESULT OF ARRAY CALC
JRST .+1 ;
;# #
TLNN TBITS,SBSCRP ;DONT FOR ARRAYS
HLL D,DISTAB(LPSA) ;CODED THIS WAY TO HANDLE USUAL CASE
JRST .+1]
TRNN A,USX ;BETTER NOT PLAN TO INDEX THIS
TLNN D,-1 ;WAS IT LOADER
ERR <DRYROT AT EVAR>,1 ;NO
HRL C,$ADR(PNT) ;PICK UP DISPL
TRO A,USX ;USE THE MOTHER
JRST DCDFX ;GO THINK ABOUT FIXING UP
DOFIX: HRRZ TEMP,PCNT ;READY TO DO FIXUP CHAINING
TRZE A,FXTWO ;USE SECOND FIXUP ADDR
JRST [HLL C,$ADR(PNT)
HRLM TEMP,$ADR(PNT) ;YES, MATTER OF FACT
JRST CHKIMM]
HRRM TEMP,$ADR(PNT) ;FINISH FIXUP CHAINING
DONTFX:
TLNN SBITS,FIXARR
JRST CHKIMM
SUB C,[XWD 1,0] ;ASSUME STRING, NOT FXTWO
TRNE TBITS,STRING ;IF NOT STRING OR IF FXTWO,
TRZE A,FXTWO
ADD C,[XWD 1,0] ; NULLIFY ASSUMPTION
CHKIMM:
TRNN A,ADDR ;DO WE WANT THIS POINTER RAW?
JRST EAC ; NO, FINISH UP
TLO A,IMMED ;THE ONLY WAY TO DO IT HERE IS TO
TRNE A,USCOND ; MAKE THE INSTR IMMEDIATE
HRLI A,(<CAI>) ; (CONDITIONAL MUST BE A CAM)
EAC: TRNE A,INDRCT ;INDIRECT BIT WANTED?
TLO A,INDIR
TRNN A,NOUSAC ;AC FLD PROHIBITED?
DPB D,[POINT 4,A,12] ;NO, PUT IT IN
TRNE A,NORLC ;RELOCATION PROHIBITED?
TLZ FF,RELOC ; YES, TAKE IT OUT
TRNE A,USCOND ;CONDITION BITS NEEDED TO FINISH OPCODE
DPB C,[POINT 3,A,8] ;YES, DO IT
TRNE A,USX ;D(LH) TO BE USED AS INDEX FLD?
TDO A,D ;YES (WIPES OUT A(RH))
HLR A,C ;GET DISPL (SO DOES THIS)
;;# # DCS 3-25-72 bad array address problem
MOVEI TEMP,CODOUT ;STANDARD CASE
TLNN FF,FFTMP1 ;IF THIS BIT GOT TURNED OFF, CODREL SHOULD
MOVEI TEMP,CODREL ; BE CALLED TO AVOID THE 0-TEST WHICH
PUSHJ P,(TEMP) ; WOULD INHIBIT RELOC -- PUT OUT THE CODE
;;# #
POP P,SBITS
POP P,TBITS
POP P,D
POP P,C
POP P,A
;;#MN# 7-13-73
SETZM LSDRLV ;REALLY ONLY NEED TO ZERO THIS
SETZM LSDRNM ;REALLY WILL DO THIS ANYHOW
;;# #
POPJ P, ;RESTORE AND RETURN
SUBTTL Generalized push and pop.
COMMENT ⊗Qstack Routines -- BPUSH, etc.⊗
DSCR QSTACK ROUTINES
DES These are routines to provide generalized, expandable push-
down stacks (buffers? queues?) for use by algorithms which need
widely varying storage, accessed in simple ways. Such structures
are called QSTACKS, and are built out of Semblks as follows --
WORD1 -- ptr to PREV,,ptr to NEXT
WORDS 2-11 -- up to 10 words of "stack" data
A stack is identified by its QPDP, or Qstack Descriptor, which is --
ptr TOP,,ptr Semblk containing TOP
Most Qstack operations reference the address where this QPDP (there
should be one QPDP which always refers to the TOP) is stored. Others
may also be used in conjunction with Qstack operations
Qstack operations are provided to PUSH data on, POP data off (these
allocate and release Semblks, if necessary, and change the TOP QPDP),
access data non-destructively in forward and reverse directions, and
to clear a given Qstack.
⊗
DSCR BPUSH
CAL PUSHJ via QPUSH macro
PAR LPSA ptr to QPDP for Qstack
A is data to be pushed
RES QPDP is updated, A is stored in Qstack, new Semblk if necessary
DES if QPDP is 0, an initial Semblk is created, QPDP constructed.
SID only TEMP is changed
SEE QPUSH
⊗
↑BPUSH: PUSH P,A ;SAVE IT.
SKIPN TEMP,(LPSA) ;THE CURRENT POINTER
JRST NEWONE ;NONE YET, GUYS.
HLRZ A,TEMP
CAIL A,BLKLEN-1(TEMP) ;GONE OVER BLOCK BOUNDARY?
JRST NOTHER ;YES
PUSH1: PUSH A,(P) ;SEE !!!
HRLM A,(LPSA) ;CURRENT POINTER UPDATED.
POP P,A ;RESTORE
POPJ P, ;DONE
NEWONE: PUSH P,LPSA
GETBLK ;GET A NEW BLOCK.
SETZM (LPSA)
MOVE TEMP,LPSA ;POINTER TO NEW BLOCK.
POP P,LPSA
MORBLK: HRRM TEMP,(LPSA) ;UPDATE PDP POINTER.
HRRZ A,TEMP
JRST PUSH1 ;FINISH OUT.
NOTHER: PUSH P,LPSA ;SAVE IT
GETBLK
MOVE TEMP,LPSA ;POINTER TO NEW ONE.
POP P,LPSA
HRRZ A,(LPSA) ;PDP POINTER.
HRLZM A,(TEMP) ;SAVE LINKS IN NEW BLOCK.
HRRM TEMP,(A) ;AND IN PDP
JRST MORBLK
DSCR BPOP
CAL PUSHJ via QPOP macro
PAR LPSA ptr to QPDP
RES A ← data from TOP, QPDP is updated
DES Semblks are released as they are emptied
SID only TEMP, A are changed
ERR if there is no QPDP, or if no more data, error
SEE QPOP
⊗
↑BPOP: SKIPN TEMP,(LPSA) ;PDP POINTER
ERR <DRYROT -- BPOP>
HLRZ A,TEMP
POPMOR: SUBI A,1 ;THIS IS A POP
CAIGE A,(TEMP) ;GONE BELOW THIS BLOCK?
JRST POPBAK ;YES ALAS
HRLM A,(LPSA) ;UPDATE PDP
MOVE A,1(A) ;THIS IS THE RESULT.
POPJ P,
POPBAK: PUSH P,TEMP
HLRZ TEMP,(TEMP) ;BACKWARD POINTER.
PUSH P,TEMP
FREBLK <-1(P)> ;DELETE THE BLOCK.
POP P,TEMP
POP P,(P) ;INGNORE THIS.
SKIPN TEMP ;IS IT THERE?
ERR <DRYROT -- BPOP>
HLLZS (TEMP) ;ZERO FORWARD POINTER
MOVEM TEMP,(LPSA) ;UPDATE PDP
MOVEI A,BLKLEN-1(TEMP) ;NEW MAX.
JRST POPMOR ;FINISH OUT.
DSCR QTAK
CAL PUSHJ, via QTAKE macro
PAR B is QPDP for data word preceding one desired
LPSA ptr QPDP for this QSTACK
RES if there is more data (check via LPSA ptr):
B is updated as if it were a BPUSH QPDP
A receives value of TOP
BTAK skips
if there is no more data:
nothing is changed
BTAK does not skip
SID only A,B, TEMP changed
SEE QTAKE macro
⊗
↑QTAK: CAMN B,(LPSA) ;OVERFLOW?
POPJ P, ;YUP
HLRZ TEMP,B
CAIL TEMP,BLKLEN-1(B) ;OVERFLOW OF OTHER TYPE?
JRST NEXTBL ;YES
TAKMOR: MOVE A,1(TEMP)
HRLI B,1(TEMP)
AOS (P)
POPJ P,
NEXTBL: HRRZ B,(B) ;GO FORWARD
HRRZ TEMP,B ;NOTE THAT THE BLOCKS ARE
JRST TAKMOR ;NOT DELETED !!!!!!
DSCR BBACK
CAL PUSHJ via QBACK macro
PAR B contains QPDP
RES B is "popped"
A receives data from TOP word
if there was data left, skip-returns -- else no-skip
SID only A, TEMP, B changed
SEE QBACK
⊗
↑↑BBACK: HLRZ A,B ;ptr to TOP, ACCORDING TO B'S QPDP
BTMOR: SUBI A,1 ;TRY THE "POP"
CAIGE A,(B) ;WAS THERE DATA LEFT HERE?
JRST BTBAK ;NO, BACK UP
HRLM A,B ;UPDATE B'S QPDP
MOVE A,1(A) ;FETCH "TOP" ELEMENT
AOS (P) ;SUCCESS UNLESS SOSED BY BTBAK
QPOPJ: POPJ P, ;DONE
BTBAK: HLRZ B,(B) ;BACK UP
JUMPE B,QPOPJ ; NO MORE DATA
MOVEI A,BLKLEN-1(B) ;RESET LH PTR
JRST BTMOR ;FINISH UP
DSCR BFLUSH
CAL PUSHJ, via QFLUSH macro
PAR LPSA ptr to QPDP
RES all Semblks cleared, QPDP zeroed
SID A, B, TEMP changed
SEE QFLUSH
⊗
↑↑BFLUSH: SKIPN A,(LPSA)
POPJ P, ;NO STACK
FLSHLP: HLRZ B,(A) ;GET NEXT PTR
FREBLK (A) ;RELEASE TOP SEMBLK
MOVE A,B
JUMPN A,FLSHLP ;MAKE NEXT ONE BACK TOP ONE
SETZM (LPSA) ;ALL DONE
POPJ P,
DSCR BBEG
CAL PUSHJ, via QBEGIN macro
PAR B is QPDP
RES B is QPDP which, when BTAKEd, returns first element in Qstack
B is 0 if no Qstack exists
SID only B, TEMP changed
SEE QBEGIN
⊗
↑↑BBEG: SKIPN B,(LPSA) ;IS THERE A STACK?
POPJ P, ; NO
LOPPP: HRLS B ;MAKE INIT QPDP FOR THIS SEMBLK
HLRZ TEMP,(B) ;GET BACK PTR
JUMPE TEMP,CPOPJ ;WHEN HAVE REACHED FIRST SEMBLK, QUIT
MOVE B,TEMP ;TRY AGAIN
JRST LOPPP
COMMENT ⊗PWR2⊗
DSCR PWR2
DES Tests number in register B for being a power of 2.
if so, it skip-returns (********) and C
has a small integer representing the power.
SID AC'S: uses TEMP
⊗;
↑PWR2: JUMPLE B,CPOPJ ;ROUTINE TO TEST B FOR A POWER OF TWO.
MOVN TEMP,B ;TWO'S COMPLEMENT.
AND TEMP,B ;AND THE AND
TLNN B,777000 ;TOO BIG ?
CAME TEMP,B ;THE MAGIC TEST FOR POWER OF TWO.
POPJ P, ;NO DICE.
FSC B,233 ;NOW THE NORMALIZE.
ASHC B,-=44 ;NOW CORRECTLY IN C. (LEFT HALF)
SUB C,[XWD 201,400000]
AOS (P)
POPJ P,
SUBTTL Generator Output Routines.
COMMENT ⊗GBOUT Description, Loader Block Format Description⊗
DSCR GBOUT -- write a block of binary output
DES
One of the specialized output routines has produced
a loader block, ready for output. These
routines are:
CODOUT -- prepares a code block. Each call
puts a word of code into a buffer and sets relocation
appropriately.
FBOUT -- prepares a fixup block. Each call puts a fixup word into
a buffer.
SOUT -- for outputting symbols. Each call puts a symbol
name (in RADIX50) and an address into a buffer.
Other parts of the generators also call GBOUT for special functions
(entry block, prog name block, etc). The routines
call GBOUT when their buffers are full or when they
wish to force out all of a given block.
Each block outputted by GBOUT has the same general format:
WD1: BLOCK TYPE,,COUNT
0 LEQ COUNT (WDn-WD3+1) LEQ 18
WD2: relocation bits
18 2-bit bytes (left-justified) corresponding
to the 18 (maximum) data words in the block.
The first bit of each is on if the left
half is to be relocated. The second bit
of each corresponds to the right half
of its data word.
WD3: first data word
.
.
.
WDn: last data word 2 LEQ n LEQ 20
The Binary file is opened and initialized in the command
scanner (outer block of SAIL). The FF bit BINARY
is on if a binary output is desired (if the file is open).
PAR B -- SIZE,,address of loader block
SIZE is size of ENTIRE block (2 + WD1's count)
It is zero if WD1's COUNT is to be believed.
RES The block is written if SIZE is GEQ 3
SID All ACS are preserved
⊗;
COMMENT ⊗ Control Variables for Loader Block Output⊗
ZERODATA (REL-FILE OUTPUT VARIABLES)
;CODPNT -- bp for relocation bits in BINTAB CODE block
; see GBOUT for details about relocation bits -- initted to --
?CODPNT: POINT 2,BINTAB+1
;FRSTSW -- off until first word of code goes out -- used to
; trigger output of program name block, initial code, etc.
; in CODOUT -- set on in CODOUt
?FRSTSW: 0
;FXPNT -- reloc bits bp for FXTAB FIXUP block -- see FBOUT, GBOUT
?FXPNT: POINT 2,FXTAB+1
;LSTRAD, LSTRLC, LSTWRD -- last radix50 word output, last code
; word output, last relocation bits output -- used by Boolean
; and ALLOT code, for repeating some of it
↑↑LSTRAD: 0
↑↑LSTRLC: 0
↑↑LSTWRD: 0
;OUTADR -- bp set up by GBOUT for fetching words from LODBLKs
; for transfer to output buffer
?OUTADR: 0
;RAD5. -- RADIX50 creates a value corresponding to a symbol comprising
; the first 5 characters of the identifier, followed by ".", in
; addition to each value it creates. It is saved here, used sometimes.
↑↑RAD5.: 0
↑↑RAD5$: 0 ;SIMILAR, BUT WITH A $
↑↑RAD5%: 0 ;GUESS WHAT
;SMPNT -- reloc bits pb for SMTAB SYMBOLS block -- see SCOUT, GBOUT
?SMPNT: 0
DATA (REL-FILE OUTPUT VARIABLES)
;SALIB -- used to place main SAIL library request in LBTAB output
; loader block -- see DONES, PRGOUT
;SALIH -- re-entrant version of library
↑SALIB: LIBLEN ;STRING CONSTANT, LIBLEN LONG
;;#HX# 6-24-72 DCS PARAMETERIZE LIBRARY NAMES
POINT 7,[LIBLOW]
REN <
↑SALIBH:LIBLEN
POINT 7,[LIBHI]
;;#HX#
>;REN
COMMENT ⊗ Loader Output Blocks-- Entry, Program Name, Initial Stuff⊗
DATA (LOADER OUTPUT BLOCKS)
COMMENT ⊗
Here are the loader output blocks. They are formatted as described
in SAILON ;;.; by Bill Weiher. The general routine GBOUT handles
the actual output of these (filled) blocks to the .REL file. For
several of the block types, special routines exist below (CODOUT,
FBOUT, etc.) to place individual words (and their relocation) into
the blocks, and to call GBOUT when a block is full
⊗
COMMENT ⊗
ENTTAB -- ENTRY block -- names included in SAIL ENTRY statements.
This must be the first block out (due both to syntax and
necessity. It allows the .REL file to be used as part
of a library.
⊗
LODBLK (ENTRY,4,ENTTAB,,=18)
COMMENT ⊗
PROGNAM -- PROGRAM NAME BLOCK -- output of this block is delayed until
first word of code goes out, to give user longest possible time
to come up with a program name. Must go out before code to name
outer block symbols and labels and stuff.
⊗
LODBLK (PROGNAM,6,BEGNAM,BEGCNT,1)
RELOC .-1
↑↑PRGTTL: RADIX50 0,M ;DEFAULT NAME, IF NO OTHER COMES
COMMENT ⊗
HBLK -- High Segment Block -- Denotes Re-entrant Output
⊗
REN <
LODBLK (HIGH,3,HBLK,HBLK2,1,,<XWD 200000,0>)
RELOC .-1
XWD 400000,400000 ;TWOSEG
>;REN
COMMENT ⊗
BEGOUT -- STANDARD INITIAL CODE SEQUENCE
This code is always put out, but is only executed (and fixups
are only correct) for Main Programs. Sample fixed-up code is
included in the comments
⊗
LODBLK (CODE,1,BEGOUT,BEGCT2,10,,<XWD 200000,0>)
RELOC .-10
↑↑BEGPC:0 ;PC ALWAYS 0 OR 400000
SKIPA ;NOT STARTED IN RPG
SETOM ;RPGSW
JSR ;SAILOR
;;%AL% THE HRLOI IS NOW DONE BY SAILOR
;; HRLOI RF,1 ;FOR FIRST LINK
PUSH P,RF
PUSH P, ;[PDA,,0]
PUSH P,SP
HRRI RF,-2(P); SET F
COMMENT ⊗ Code, Boolean Code, Fixups, Links⊗
COMMENT ⊗
BINTAB -- MAIN CODE BLOCK
All generated instructions are output via CODOUT-GBOUT
to this block. See CODOUT for details
⊗
LODBLK (CODE,1,BINTAB,,=18)
COMMENT ⊗
BOLOUT -- SPECIAL BOOLEAN CODE BLOCK
Conditionals are output once when a condition is seen, and
again (with fixups and compare op codes correct) when the
entire Boolean expression has been parsed and analyzed.
See BOOLEAN for details.
⊗
LODBLK (CODE,1,BOLOUT,,0,,<XWD 200000,0>)
↑↑BRELC←.-1 ;TO ACCESS RELOCATION BITS
↑↑BPCNT: 0 ;PROGRAM COUNTER -- SAME AS WHEN INSTRS FIRST OUT
↑↑BWRD1: 0 ;COMPARE, SKIP, OR CONDITIONAL JUMP
↑↑BWRD2: 0 ;UNCONDITIONAL JUMP IF BWRD1 WAS A COMPARE OR SKIP
COMMENT ⊗
FXTAB -- FIXUPS
Each word contains in its right half the address or stack
displacement (reloc bits adj. accordingly) of a variable
or instruction. The left half contains the address
(relative to 0, of course) of the last instruction or data
which requires this address field. This location, in turn,
was compiled to refer to the next previous use of the variable
or whatever... in other words, a fixup chain (terminates in 0).
The LOADER uses these fixups to handle forward references to
things. See FBOUT for details
⊗
LODBLK (FIXUPS,10,FXTAB,,=18,-1)
COMMENT ⊗
SMTAB -- SYMBOLS
All local and internal symbols, and global requests, are output
through this block. See SCOUT and friends for details.
⊗
LODBLK (SYMBOLS,2,SMTAB,,=18,<XWD 42104,210421>)
;(RELOCATE EVERY OTHER WORD -- GENERALLY)
COMMENT ⊗
SLNKBK -- LINK BLOCKS
The string link, space link, and other links are output
through this block. These links provide inter-RELfile
communication (best example is link that chains all string
variables together, so that STRNGC can get at them. See
LNKOUT for details.
⊗
LODBLK (LINK,12,SLNKBK,SDSCRP,2,,<XWD 40000,0>)
RELOC .-2
↑↑LNKNM: 1 ;USUALLY STRING LINK, BY CONVENTION #1
;SPACE LINK IS #2
;SET LINK IS #3
;STRNGC ROUTINE NAMES LINK IS #4
; THESE ARE SAIL CONVENTIONS ONLY
↑↑SLNKWD: 0 ;ADDRESS OF ELEMENT OF CHAIN
COMMENT ⊗ Space Allocation Block
SBCTBL -- SPACE ALLOCATION BLOCK
In this block is collected all REQUIRE specifications
(except LOAD!MODULES, LIBRARIES, SOURCE!FILES) and
space limits (string space, system pdl, new items, etc.)
It is output as a code block. Also output is a link
block tying this space block to all the others loaded
together. The SAILOR (initialization) routine uses this
information to provide an environment pleasing to the user.
See DONES and the REQUIRE code for more details. Also GOGOL
(%ALLOC) for block format explanations
⊗
NOHACK <
;;% % RHT ALLOW COMVER THING FOR EVERYONE (BUT KEEP EXPO FOR NOW)
↑↑SPCSIZ←←=15
>;NOHACK
HACK <
↑↑SPCSIZ←←=14 ;BAD OLD VALUE *****
>;HACK
↑↑SPCTBL:XWD 1,SPCSIZ ;CODE BLOCK, AT LEAST SPCSIZ LONG
BYTE (2) 1,0,0,0,0,1,0,0,0,0,0,0,1,1 ;PC WORD,MESLNK,TINIT,PINIT(RELOC)
↑SPCPC: 0 ;PC LOCATION
0 ;LINK BLOCK PROVIDES CHAIN THROUGH THIS LOC
;; %AG% HAVE ITEMNO KEEP BOTH MIN AND MAX
↑ITEMNO:0 ;MIN,,MAX ITEM NUMBER DECLARED THIS COMPILATION
↑NWITM: 0 ;REQUIRE n NEW!ITEMS PUTS n HERE
;; %AG% ! HAVE GITEMNO CONTAIN LEAPIS FLAG
↑GITEMNO:0 ;XWD LEAPIS,MAX (MIN?) GLOBAL ITEM NUMBER DECLARED
↑MESLNK:0 ;POINTER TO MESSAGE PROCEDURE LIST PUT HERE
↑PNAMNO:0 ;REQUIRE n PNAMES PUTS n HERE
↑VERNO: 0 ;REQUIRE n VERSION PUTS n HERE
↑SEGNAM:0 ;REQUIRE "name" SEGMENT!NAME PUTS "name" HERE IN SIXBIT
↑SEGDEV:0 ;REQUIRE "dev:file[p,pn]" SEGMENT!FILE PUTS
↑SEGFIL:0 ; dev, file, ppn IN THESE LOCS IN SIXBIT
↑SEGPPN:0 ;(LOW BIT OF DEV IS SEGMENT PROTECT BIT, NOT USED NOW)
↑TINIT: 0 ;INITIALIZATION BLOCK ADDRESS FOR DECLARED ITEM TYPES
↑PINIT: 0 ;INIT. BLOCK FOR PNAMES(DECLARED ITEMS)
NOHACK <
;;% % RHT ***** OUGHT TO MAKE OFFICIAL SOMEDAY *******
↑↑COMVER: 0 ;NICE THING, BUT SUAI IS REACTIONARY
>;NOHACK
BLOCK 50 ;ROOM FOR MORE REQUESTS
↑SPCEND←←.-1
COMMENT ⊗ Request Blocks -- RELfile, Libraries⊗
COMMENT ⊗
PRGTAB -- RELFILE REQUEST BLOCK
REQUIRE "...." LOAD!MODULE generates one of these. The LOADER
loads all requested .REL files after loading all the explicit
stuff. See REQUIRE code for details
⊗
;; #KS# ADD LOADVR SWITCH
IFN (LOADVR-=54), <
LODBLK (RELREQ,15,PRGTAB,,=18)
>
IFE (LOADVR-=54), <
LODBLK (RELREQ,16,PRGTAB,,=18)
>
;; #KS#
COMMENT ⊗
LBTAB -- LIBRARY REQUEST BLOCK
REQUIRE "...." LIBRARY generates one of these (SAIL main programs
automatically request SYS:LIBSAI.REL). The LOADER searches these
libraries, if necessary, after searching all the others except the
automatic F4 search.
⊗
;; #KS# LOADVR SWITCH
IFN (LOADVR-=54), <
LODBLK (LIBREQ,16,LBTAB,,=18)
>
IFE (LOADVR-=54), <
LODBLK (LIBREQ,17,LBTAB,,=18)
>
;; #KS#
COMMENT ⊗ Ending Code, Symbols -- END Block
STAROT ETC. -- ENDING STUFF.
These include some constant ending code, some extra standard
symbols, the starting address block, if there is one, and so on.
It's too messy to use the LODBLK macro on, so here it is in
all its glory--
⊗
EBLEN←←. ;COLLECT LENGTH.
;If this is a Main Program, a starting address block is issued
; (via the GBOUT descriptor EBDSC); else EBDSC1 is used to issue
; all but the starting address block. Starting address is always
; relative 0 (addr of the BEGOUT code--see above)
?STAROT: XWD 7,1 ;STARTING ADDR BLOCK -- 1 DATA WORD
XWD 200000,0 ;RELOCATE ADDRESS (RH)
↑STRDDR:0 ;STARTING ADDRESS ALWAYS REL 0
; If Main Program, global requests must be issued to fill in
; the RPGSW and SAILOR blanks in the BEGOUT block (above)
XWD 2,4 ;SYMBOL BLOCK
XWD 42104,210421 ;EVERY OTHER WORD.
↑CONSYM:RADIX50 60,SAILOR;JSR REQUEST.
2 ;JSR IS IN LOC 2
RADIX50 60,RPGSW;FOR SETOM RPGSW BUSINESS
1 ;SETOM IS IN 1
; This part is always issued -- standard symbol names, end block
NOSTAR: XWD 2,STRCT-NOSTAR-2;SYMBOLS
XWD 40000,0;RELOCATE ONLY S.
RADIX50 10,S. ;FIRST EXECUTABLE LOC IN PROG
0 ;ALWAYS 0
RADIX50 10,P ;SYSTEM PDP ADDR
RP ;USUALLY 17
RADIX50 10,SP ;STRING PDP ADDR
RSP ;USUALLY 16
RADIX50 10,ARERR;UUO FOR ARRAY INDEX OV/UNDERFLOW
ARERR ;THE UUO OPCODE
RADIX50 10,FLOAT;UUO FOR INTEGER to REAL
FLOAT
RADIX50 10,FIX ;UUO FOR REAL to INTEGER
FIX
STRCT: ;END OF EXTRA SYMBOLS
; END BLOCK
NOREN <
XWD 5,1 ;END BLOCK.
XWD 200000,0 ;RELOCATE PROGRAM BREAK WORD
↑↑PRGBRK: 0 ;PROGRAM BREAK-- FIRST NON-USED ADDR
>;NOREN
REN <
XWD 5,2 ;TWO PROGRAM BREAKS
XWD 240000,0 ;RELOCATE PROGRAM BREAK WORD
↑↑PRGBRK: 0 ;HIGH-SEG PROGRAM BREAK
0 ;LOW-SEG PROGRAM BREAK
>;REN
EBLEN←← .-EBLEN ;LENGTH OF ENTIRE OUTPUT RITUAL
↑EBDSC: XWD EBLEN,STAROT ;IF MAIN PROGRAM
↑EBDSC1:XWD EBLEN+STAROT-NOSTAR,NOSTAR ;IF NOT
ENDDATA
COMMENT ⊗ RELINI -- Loader Block Initialization⊗
DSCR RELINI
CAL PUSHJ FROM GENINI
DES SETS UP ALL REL-FILE OUTPUT STUFF BEFORE EACH COMPILATION
⊗
↑↑RELINI:
HLLZS BINTAB
HLLZS FXTAB
SETOM FXTAB+1 ;ALL RELOCATABLE
HLLZS SMTAB ;CLEARS OUTPUT BUFFER COUNTS
HLLZS PRGTAB ;PROGRAM AND LIBRARY REQUEST BLOCKS
HLLZS LBTAB
MOVE A,[XWD SPCPC,SPCPC+1] ;CLEAR SPACE ALLOCATION BLOCK
SETZM SPCPC
BLT A,SPCEND ;SIZE ALLOCATION BLOCK.
HRRI TEMP,SPCSIZ
HRRM TEMP,SPCTBL
POPJ P, ;RETURN TO GENINI
COMMENT ⊗ GBOUT Routine⊗
↑GBOUT:
PUSH P,A ;SAVE A
PUSH P,B ;SAVE ADDRESS OF BUFFER
HLRZ A,B ;GET COUNT IF NONSTANDARD
TLO FF,IREGCT ;SET NON-STANDARD COUNT BIT
HRLI B,(<POINT 36,0>) ;FOR PICKING UP WORDS
MOVEM B,OUTADR ;SAVE TABLE ADDRESS
JUMPN A,GBOUTA ;NOT STANDARD (FROM TABLE) COUNT
HRRZ A,(B) ;GET COUNT FROM BLOCK
ADDI A,2 ; +2 FOR BLOCK TYPE & RELOC
TLZ FF,IREGCT ;RESET NON-STANDARD COUNT BIT
; OUTPUT ROUTINE
GBOUTA: TLNN FF,BINARY ;IS THERE A BINARY FILE?
JRST OUTDUN ;NO, DON'T WRITE
CAIGE A,3 ;IS THERE ANYTHING TO WRITE?
JRST OUTDUN ;NO, DON'T DO IT
BQN: SOSLE BINCNT ;FULL?
JRST OKOUT ;NO
OUTPUT BIN,0 ;EMPTY BUFFER, ON TO NEXT
TSTERR BIN ;ERRORS?
ERR <OUTPUT ERROR ON BINARY FILE>
OKOUT: ILDB B,OUTADR ;BLOCK WORD
IDPB B,BINPNT
SOJG A,BQN ;WRITE THEM ALL
OUTDUN: POP P,B ;GET BUFFER ADDR BACK
TLZN FF,IREGCT ;DON-'T CLEAR IF NON-STANDARD COUNT
HLLZS (B) ;CLEAR COUNT
POP P,A ;RESTORE A
POPJ P,
COMMENT ⊗ CODOUT Routine -- Output Code or Data⊗
DSCR CODOUT -- WRITE DATA (ALSO CODREL)
PAR WORD IN "A"
relocatable if RELOC in in "FF"
(if rh of A is zero, then never RELOC. If you want to
TO BYPASS THIS TEST, CALL "CODREL").
RES Writes word, increments program counter (PCNT)
SID Uses A,B,C -- Saves all
⊗;
↑CODOUT:
SKIPE NOEMIT ; GET OUT IF NO CODE IS TO BE EMITTED (I.E.
POPJ P, ; EXPR!TYPE)
PUSH P,A
PUSH P,B
SKIPE FRSTSW ;HAVE WE DONE THIS BEFORE
JRST COD1 ; YES, DON'T DO AGAIN
SETOM FRSTSW
PUSH P,LPSA ;AND SOME OTHERS
MOVEI LPSA,IPROC ;GET PROGRAM NAME.
PUSHJ P,RAD50 ;IN RADIX50
TLZ A,740000 ;RADIX50 0,NAME
MOVEM A,PRGTTL
MOVE B,BEGCNT
PUSHJ P,GBOUT ;WRITE NAME BLOCK
REN <
MOVEI A,0
SKIPN HISW ;TWO-SEGMENT PROGRAM?
JRST JUST1 ;NO
MOVE B,HBLK2 ;YES, WRITE HISEG (TYPE 3) BLOCK
PUSHJ P,GBOUT
MOVEI A,400000 ;BEGINNING PC
JUST1:
MOVEM A,BEGPC ;IN WHICH SEGMENT
>;REN
MOVE B,BEGCT2 ;CALL TO INIT & LINKAGE
PUSHJ P,GBOUT
COD2: POP P,LPSA
MOVE A,-1(P) ;RESTORE A.
COD1: TRNN A,-1 ;ZERO ADDRESS?
TLZ FF,RELOC ;YES, NO RELOC
JRST CDRL1
↑CODREL:
PUSH P,A ;ENTER HERE TO BYPASS ZERO TEST
PUSH P,B
CDRL1:
HRRZ B,BINTAB ;GET COUNT
JUMPN B,BAQ ;FIRST WORD OF BLOCK?
AOS BINTAB ;YES, SET UP BLOCK
MOVE B,PCNT ;SET LOCATION WORD
MOVEM B,BINTAB+2 ;INTO 3D WORD OF BLOCK
SETZM BINTAB+1 ;CLEAR RELOCATION BITS
MOVE B,[POINT 2,BINTAB+1] ;BYTE POINTER FOR RELOC BITS
MOVEM B,CODPNT ;TO RIGHT PLACE
MOVEI B,1 ;RELOCATE THE LOC COUNTER WORD
IDPB B,CODPNT
BAQ: AOS B,BINTAB ;INCREMENT COUNT
HRRZS B ;AND MOVE TO B
MOVEM A,BINTAB+1(B) ;DEPOSIT WORD
MOVEM A,LSTWRD ;SAVE LAST WORD OUTPUT
LDB A,[POINT 1,FF,RLCPOS] ;RELOC?
SKIPE LHRELC ;RELOC LEFT HALF?
ADDI A,2 ;SAY SO
MOVEM A,LSTRLC ;AND LAST RELOCATION BIT.
IDPB A,CODPNT ;SET RELOC BITS
AOS PCNT ;INCREMENT COUNT
CAIGE B,22 ;FULL?
JRST CDRET ;NO, RETURN
MOVEI B,BINTAB ;INDICATE STANDARD COUNT AND WHICH TABLE
PUSHJ P,GBOUT ;WRITE BLOCK
; JRST CDRET
CDRET: POP P,B
POP P,A
POPJ P,
↑CODLRL: ;RELOCATE LEFT HALF -- FF SAYS ABOUT RIGHT HALF
TLNE A,-1 ;NEVER RELOCATE 0
SETOM LHRELC ;SET FLAG
PUSHJ P,CODOUT
SETZM LHRELC
POPJ P,
ZERODATA( DISPLAY STUFF)
LHRELC: 0
ENDDATA
DSCR FRBT
DES Force out current binary (BINTAB) code block,
even if it's not full yet. This is done whenever
symbols or fixups which might refer to this code
are put out, so that there is something to fixup
or refer to symbolically. It is also called from DONES.
SID Saves all ACS
⊗
↑FRBT: PUSH P,B
MOVEI B,BINTAB
PUSHJ P,GBOUT ;CLEAR BINARY BUFFER
POP P,B
POPJ P,
COMMENT ⊗ FBOUT, etc. -- Output Fixups⊗
DSCR FBOUT,FIXOUT,FBOSWP
DES Put word of fixup information into output file.
PAR B contains fixup specification:
lh -- PCNT of actual location of entity
rh -- PCNT of last word in fixup chain.
FBOSWP takes the above B value, swapped.
RES This word is written into the FXTAB fixup Loader
block via GBOUT (when there are enough).
FBOUT always assumes both halves reloatable
FIXOUT always assumes the actual (lh) address is not
relocatable
FBOSWP is included for convenience
SID Saves all ACs
⊗;
↑FXOSW2: MOVSS B
PUSHJ P,FIXOUT
MOVSS B
POPJ P,
↑FBOSW2: MOVSS B
PUSHJ P,FBOUT
MOVSS B
POPJ P,
↑FBOSWP: MOVSS B
↑FBOUT: SKIPE NOEMIT ; GET OUT IF NO CODE IS TO BE EMITTED (I.E.
POPJ P, ; EXPR!TYPE)
TLNN B,-1 ;IS LEFT HALF ZERO?
ERR <DRYROT -- FBOUT>,1
TLOA FF,FFTEMP ;USE RELOCATION IN FIXUP SIDE
↑FIXOUT:
TLZ FF,FFTEMP ;DO NOT RELOCATE FIXUP PART
PUSH P,B
PUSH P,A ;SAVE A
HRRZ A,FXTAB
JUMPN A,FAQ ;FIRST WORD OF BLOCK?
MOVE A,[POINT 2,FXTAB+1] ;YES, RESET RELOCATION BIT POINTER
MOVEM A,FXPNT ; (SEE CODOUT FOR SIMILARITIES)
FAQ:
AOS A,FXTAB ;INCREMENT AND FETCH COUNT
HRRZS A
MOVEM B,FXTAB+1(A) ;DEPOSIT WORD
MOVEI B,3 ;ASSUME BOTH HALVES RELOC
TLNN FF,FFTEMP ;TEST ASSUMPTION
MOVEI B,2 ; WRONG
IDPB B,FXPNT ;INSERT RELOCATION BITS
CAIGE A,22 ;FULL?
JRST FXRET ;NO, RETURN
PUSHJ P,FRBT ;FORCE OUT ANY BINARY
;(BECAUSE FIXUPS HAVE TO COME AFTER)
MOVEI B,FXTAB
PUSHJ P,GBOUT ;WRITE BLOCK
FXRET: POP P,A
POP P,B
POPJ P,
COMMENT ⊗ SCOUT, etc. -- Output Symbols⊗
DSCR SOUT,SCOUT,SHOUT,SCOUT0
DES Output symbols in RADIX50 -- many ways exist for
obtaining symbols for output, thus the proliferation.
PAR
SOUT: LPSA -- Semantics ptr. $PNAME and $ADR are used to
obtain the symbol and address.
SHOUT: LPSA -- descriptor of the form:
bits 0-5 DDT symbol type
6-17 #characters
18-35 address of string in ASCII (assumed justified)
B -- address for symbol
SCOUT: A -- RADIX50 for symbol
B -- address for symbol
SCOUT0: SAME AS SCOUT, BUT MAKES SYMBOL NON-RELOCATABLE.
SID A, TEMP, may be different on exit
⊗;
↑SHOUT: PUSHJ P,RAD52
JRST SCOUT ;MAKE RADIX50 FROM DESCRIPTOR
↑SCOUT0: PUSH P,B ;NON-RELOCATED SYMBOL
MOVEI TEMP,0
JRST SASS
↑SOUT: PUSHJ P,RAD50 ;GET RADIX50 FOR SYMBOL
PUSH P,B ;SAVE IT
;;# # RHT 3-19-73 MAKE RECSV SYMBOLS GO OUT UNRELOC
HRRZ B,$ADR(LPSA) ;GET ADDRESS
MOVE TEMP,$SBITS(LPSA);DOES THIS SYMBOL USE THE STACK?
TRNN TEMP,DLFLDM ;
JRST SOUT.0 ;NO
CAIGE B,20 ;HALF KILL??
TLO A,400000 ;YES
MOVEI TEMP,0 ;
JRST SASS
;;# # RHT
;;# # RHT -- 7-13-73 EXTRA KLUGE TO USE THE RAD5$ SYMBOL FOR
;; SPECIAL BILTIN RUNTIMES
SOUT.0: SETCM TEMP,$TBITS(LPSA)
TLNE TEMP,FNYNAM+OWN+EXTRNL
JRST SOUT.1 ;REGULAR
SKIPA A,RAD5$ ;PREMIUM
;;# #
↑SCOUT: PUSH P,B ;SAVE
SOUT.1: MOVEI TEMP,1 ;RELOCATION BIT.
SASS: PUSH P,C
HRRZ C,SMTAB
JUMPN C,SAQ
MOVE C,[POINT 4,SMTAB+1]
MOVEM C,SMPNT
SAQ:
CAMN A,LSTRAD ;RADIX50 FOR LAST BLOCK NAME.
JRST SYMRET ;DO NOT PUT IT OUT.
AOS C,SMTAB ;BINARY DOES NOT HAVE TO BE
HRRZS B ;FORCED OUT
MOVEM A,SMTAB+1(C)
MOVEM B,SMTAB+2(C)
AOS C,SMTAB
HRRZS C
LDB B,[POINT 4,A,3] ;DON'T RELOCATE BLOCK LEVELS
CAIN B,3 ;BLOCK TYPE 14
MOVEI TEMP,0
IDPB TEMP,SMPNT
CAIGE C,22
JRST SYMRET
PUSHJ P,FRBT ;MAKE BINARY GO FIRST
MOVEI B,SMTAB
PUSHJ P,GBOUT
SYMRET: POP P,C
POP P,B
POPJ P,
COMMENT ⊗ LNKOUT -- Output Linkage Block⊗
DSCR LNKOUT --
DES Put out a (type 12) Link block via GBOUT. These blocks
allow chains of addresses to be created through separate
.REL files. STRINGC uses LINK 1 to find all its strings.
Other uses are for SETS, STRINGC routine names, and the
space allocation block.
PAR B -- link number
PCNT -- decremented by one; that is address for LINK rqst.
⊗
↑LNKOUT: MOVEM B,LNKNM ;SAVE LINK NUMBER
PUSHJ P,FRBT ;NOTE DOES NOT SAVE ACS
HRRZ TEMP,PCNT
SUBI TEMP,1 ;LAST WORD OUTPUT WILL HOLD LINK
HRRZM TEMP,SLNKWD ;PLACE IN ADDR WORD OF LINK BLOCK TEMPLATE
MOVE B,SDSCRP ;DESCRIPTOR OF LINK BLOCK [COUNT,ADDR OF TEMPLATE]
PUSHJ P,GBOUT
POPJ P, ;RETURN AFTER WRITING BLOCK
COMMENT ⊗ PRGOUT, FILSCN -- Output Request Blocks, Scan for Source!file Rqst⊗
DSCR FILSCN -- CONVERT ASCII FILE-STRING TO SIXBIT
PAR PNAME, PNAME+1 describe a String representing the file
name.
RES A, C, D return DEVICE, FILENAME, and PPN in SIXBIT
DES Converts String to SIXBIT via FILNAM routine (approp-
riately informed) in Command Scanner (SAIL). Extension
not returned, because there's currenlty no need.
SID Nothing much saved
SEE FILNAM, PRGOUT, RQSET, SRCSWT
⊗
↑↑FILSCN: SETOM TYICORE ;TYI IN COMND WILL GET CHARS FRM STRNG
PUSH P,DEVICE ;SAVE FILE DATA
PUSH P,EXTEN
PUSH P,SAVTYI
PUSH P,EOL
SETZM SAVTYI ;NO SCAN-AHEAD
MOVSI TEMP,(<SIXBIT /DSK/>) ;DEFAULT DEVICE
MOVEM TEMP,DEVICE
PUSHJ P,FILNAM ;GET SIXBITS IN NAME, EXTEN, ETC.
MOVE A,DEVICE ;LOAD RESULTS
MOVE C,NAME
MOVE D,PPN
POP P,EOL
POP P,SAVTYI
POP P,EXTEN
POP P,DEVICE ;RESTORE OLD VALUES
POPJ P,
DSCR PRGOUT -- OUTPUT PROGRAM AND LIBRARY REQUEST BLOCKS
DES Output (via GBOUT) Program and Libraray REQUEST BLOCKS.
PAR B ptr to PRGTAB or LBTAB (program or library request)
PNAME, PNAME+1 as in FILSCN
Defaults as in FILSCN; DEVICE, FILE and PPN will be passed
to the loader.
RES FILSCN is called to make SIXBIT representations of DEVICE,
FILE, and PPN; these are placed in the output block.
SID Saves the world
⊗;
↑↑PRGOUT:
MOVE USER,GOGTAB ;SAVE ACS IN USER TABLE AREA
HRRZI TEMP,RACS(USER)
BLT TEMP,SBITS2+RACS(USER) ;FILNAME USES MANY ACS
PUSHJ P,FILSCN ;GET SIXBITS IN A,C,D
MOVE B,RACS+2(USER) ;GET TABLE ADDRESS BACK
MOVEI TEMP,3 ;PREPARE TO COUNT UP BLOCK COUNT
ADDB TEMP,(B)
ADDI TEMP,(B) ;ptr to AREAS TO BE FILLED
MOVEM C,-1(TEMP) ;STORE NAME
MOVEM D,00(TEMP) ;STORE PPN
MOVEM A,01(TEMP) ;STORE DEVICE
HRRZS TEMP
CAIL TEMP,22(B) ;BLOCK FULL?
PUSHJ P,GBOUT ;YES, PUT IT OUT
HRLZI TEMP,RACS(USER)
BLT TEMP,SBITS2
POPJ P, ;TRA 0,4?
SUBTTL Generator Miscellaneous.
COMMENT ⊗ RAD50, RAD52 -- Radix-50 Functions for Scout Routines⊗
DSCR RAD50,RAD52 -- create a RADIX50 symbol
PAR RAD50 -- LPSA pntr to block head -- string is in $PNAME, etc.
RAD52 -- LPSA(lh) is count, LPSA (rh) is address of string,
assumed aligned.
RES RADIX50 for symbol in A
SID Results in A, all other ACS saved (except TEMP)
⊗;
↑RAD50:
EXCH SP,STPSAV
MOVSS POVTAB+6 ;ENABLE FOR STRING PDL OV
PUSH SP,$PNAME(LPSA) ;COLLECT POINTERS IN COMMON SPOT
PUSH SP,$PNAME+1(LPSA)
HRRZS -1(SP) ;CLEAR STRNO, SAVE COUNT
MOVE A,$TBITS(LPSA) ;CONTROLS MODE BITS IN RAD50 SYMBOL
MOVEI TEMP,10/4 ;ASSUME LOCAL
TLNE A,INTRNL ;INTERNAL IS TYPE 4
MOVEI TEMP,4/4
TLNE A,EXTRNL
MOVEI TEMP,60/4 ;EXTERNAL IS TYPE 60
MOVEI A,0 ;INITIALIZE A
JRST RAD5
↑RAD52:
LDB TEMP,[POINT 12,LPSA,17] ;COUNT
EXCH SP,STPSAV
MOVSS POVTAB+6 ;ENABLE FOR STRING PDLOV
PUSH SP,TEMP
PUSH SP,LPSA ;MAKE IT LOOK LIKE STRING
HRRI TEMP,(<POINT 7,0>) ; DESCRIPTOR
HRLM TEMP,(SP)
MOVEI A,0
LDB TEMP,[POINT 4,LPSA,3]
RAD5: PUSH P,TEMP
PUSH P,B ;SAVE IT
MOVEI TEMP,6
R50LUP: SOSGE -1(SP) ;QUIT IF NO MORE STRING
JRST R5OUT
ILDB B,(SP) ;CHARACTER
CAIN B," " ;IGNORE BLANKS ABSOLUTELY!
JRST R50LUP ; THIS RUNS ALL THE CHARACTERS TOGETHER
CAIL B,"a"
CAILE B,"z"
JRST .+2
SUBI B,40 ;CONVERT TO UPPER CASE
CAIE B,30 ;UNDERLINE:THESE CHARS HAVE TO BE CREATED INDIVIDUALLY
CAIN B,"."
MOVEI B,66+45 ;RAD50 CHAR FOR "." + 66 TO BE SUBTRACTED
;;#GQ# DCS 2-8-72 (1-1) ! SAME AS UNDERLINE
CAIN B,"!" ;! SAME AS UNDERLINE
MOVEI B,66+45 ;"."
;;#GQ# (1)
CAIN B,"$"
MOVEI B,66+46
CAIN B,"%"
MOVEI B,66+47
SUBI B,66 ;OK IF A LETTER
CAIG B,12 ;<12 IF A NUMBER
ADDI B,7 ; THIS MAKES IT RIGHT
IMULI A,50 ;THAT'S THE NUMBER ALL RIGHT
ADD A,B ;COLLECT RADIX50
SOJN TEMP,R50LUP ;QUIT AT 6
R5OUT: MOVEM A,RAD5. ;NOW CREATE SAME SYMBOL WITH
JUMPLE TEMP,MORFIV ;MORE THAN FIVE CHARS?
IMULI A,50 ;MAKE IT "SYMB".
SKIPA
MORFIV: SUB A,B ;"." IN PLACE OF THE LAST
POP P,B ;RESTORE B
POP P,TEMP ;TYPE BITS.
DPB TEMP,[POINT 4,A,3] ;TYPE BITS TO RADIX 50
ADDI A,46 ;$
MOVEM A,RAD5$
ADDI A,1 ;%
MOVEM A,RAD5% ;
SUBI A,2 ;"."
EXCH A,RAD5. ; AND STORE IT IN RAD5. FOR STRINGS
DPB TEMP,[POINT 4,A,3] ;TYPE BITS TO RADIX 50
SUB SP,X22
EXCH SP,STPSAV ;RESTORE REGS
MOVSS POVTAB+6 ;RE-ENABLE FOR PARSE PDLOV
POPJ P,
BEND TOTAL
IFN FTDEBUG, <↑INNA←INNA>